From 1425ed3f568a859d065cfb6fe523c81db3464250 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Fri, 9 Aug 2024 09:50:22 +0200 Subject: [PATCH 1/4] Work around fourmolu parse error --- bittide/src/Bittide/Link.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/bittide/src/Bittide/Link.hs b/bittide/src/Bittide/Link.hs index 5cf49020c..c8e24eab7 100644 --- a/bittide/src/Bittide/Link.hs +++ b/bittide/src/Bittide/Link.hs @@ -71,9 +71,8 @@ txUnit :: , Signal core (DataLink frameWidth)) txUnit (getRegsBe -> RegisterBank preamble) sq frameIn wbIn = (wbOut, frameOut) where - (stateMachineOn, wbOut) - | Dict <- timesDivRU @(nBytes * 8) @1 - = registerWb WishbonePriority False wbIn (pure Nothing) + (stateMachineOn, wbOut) = case timesDivRU @(nBytes * 8) @1 of + Dict -> registerWb WishbonePriority False wbIn (pure Nothing) frameOut = withReset regReset $ mealy stateMachine (scErr, LinkThrough) mealyIn mealyIn = bundle (frameIn, sq) From 0a4f9798543914d111c454d8e77b15285c7ce664 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Wed, 7 Aug 2024 17:09:35 +0200 Subject: [PATCH 2/4] Add fourmolu --- .github/scripts/fourmolu.sh | 9 ++++++++ .github/workflows/ci.yml | 43 +++++++++++++++++++++---------------- .vscode/settings.json | 2 +- cabal.project | 2 +- fourmolu.yaml | 5 +++++ nix/bin/format | 5 ++++- shell.nix | 1 + 7 files changed, 45 insertions(+), 22 deletions(-) create mode 100755 .github/scripts/fourmolu.sh create mode 100644 fourmolu.yaml diff --git a/.github/scripts/fourmolu.sh b/.github/scripts/fourmolu.sh new file mode 100755 index 000000000..163820b43 --- /dev/null +++ b/.github/scripts/fourmolu.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash +# SPDX-FileCopyrightText: 2024 Google LLC +# +# SPDX-License-Identifier: Apache-2.0 +set -euf -o pipefail + +git ls-files *.hs \ + | grep --extended-regexp --invert-match '^clash-vexriscv/' \ + | xargs --max-procs=0 -I {} fourmolu --quiet --mode inplace "{}" diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f3931f76e..0e2d9d56c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -45,7 +45,7 @@ jobs: run: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_SHA" --keep "S3_PASSWORD" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: - name: Checkout @@ -73,7 +73,7 @@ jobs: shell: git-nix-shell {0} --option connect-timeout 360 container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -104,7 +104,12 @@ jobs: - name: Check that all cabal files are formatted correctly run: | - .github/scripts/cabal-gild.sh check + .github/scripts/cabal-gild.sh + git diff --exit-code + + - name: Check that all Haskell files are formatted correctly + run: | + .github/scripts/fourmolu.sh git diff --exit-code - name: Check that we don't introduce accidental infinite loops in type checkers @@ -119,7 +124,7 @@ jobs: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_SHA" --keep "S3_PASSWORD" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -159,7 +164,7 @@ jobs: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_OUTPUT" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -199,7 +204,7 @@ jobs: fail-fast: false container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -256,7 +261,7 @@ jobs: ] container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -329,7 +334,7 @@ jobs: needs: [build, lint] container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -356,7 +361,7 @@ jobs: needs: [build, lint] container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -397,7 +402,7 @@ jobs: run: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_SHA" --keep "S3_PASSWORD" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g needs: [build] @@ -422,7 +427,7 @@ jobs: run: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_SHA" --keep "S3_PASSWORD" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g needs: [build] @@ -450,7 +455,7 @@ jobs: run: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_SHA" --keep "S3_PASSWORD" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g needs: [build] @@ -476,7 +481,7 @@ jobs: run: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_SHA" --keep "S3_PASSWORD" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g needs: [build] @@ -509,7 +514,7 @@ jobs: needs: [build, lint] container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -536,7 +541,7 @@ jobs: needs: [build, lint] container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -562,7 +567,7 @@ jobs: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_OUTPUT" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -595,7 +600,7 @@ jobs: shell: git-nix-shell {0} --option connect-timeout 360 --pure --keep "GITHUB_OUTPUT" container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 options: --memory=11g steps: @@ -643,7 +648,7 @@ jobs: fail-fast: false container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 volumes: - /opt/tools:/opt/tools options: --init --mac-address="6c:5a:b0:6c:13:0b" --memory=11g @@ -723,7 +728,7 @@ jobs: fail-fast: false container: - image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-06 + image: ghcr.io/clash-lang/nixos-bittide-hardware:2024-08-07 volumes: - /opt/tools:/opt/tools - /dev:/dev diff --git a/.vscode/settings.json b/.vscode/settings.json index 3578df5ea..61232bd43 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -15,7 +15,7 @@ "files.trimTrailingWhitespace": true, "editor.rulers": [ 80, - 100 + 90 ], "editor.tabSize": 2, "[rust]": { diff --git a/cabal.project b/cabal.project index e5c1a138b..caa9a2ad7 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ write-ghc-environment-files: always -- index state, to go along with the cabal.project.freeze file. update the index -- state by running `cabal update` twice and looking at the index state it -- displays to you (as the second update will be a no-op) -index-state: 2024-08-06T03:18:13Z +index-state: 2024-08-07T03:18:13Z with-compiler: ghc-9.4.7 tests: True diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 000000000..612370822 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,5 @@ +# SPDX-FileCopyrightText: 2024 Google LLC +# +# SPDX-License-Identifier: CC0-1.0 +indentation: 2 +column-limit: 90 diff --git a/nix/bin/format b/nix/bin/format index 52ed4ac9e..2f79e5586 100755 --- a/nix/bin/format +++ b/nix/bin/format @@ -8,4 +8,7 @@ echo "Formatting Cabal files.." "${ROOT}"/.github/scripts/cabal-gild.sh echo "Formatting Rust files.." -./cargo.sh fmt --all -- --emit files +"${ROOT}"/cargo.sh fmt --all -- --emit files + +echo "Formatting Haskell files.." +"${ROOT}"/.github/scripts/fourmolu.sh diff --git a/shell.nix b/shell.nix index a3388b7cc..03859f3b5 100644 --- a/shell.nix +++ b/shell.nix @@ -15,6 +15,7 @@ pkgs.mkShell { [ pkgs.cabal-install pkgs.haskellPackages.cabal-gild + pkgs.haskellPackages.fourmolu pkgs.dtc pkgs.gcc From a4e4b4b8833acdc0d1f9c488d01e827a04598d98 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Fri, 9 Aug 2024 11:00:03 +0200 Subject: [PATCH 3/4] Format files using fourmolu Closes #548 --- .../src/Bittide/Github/Artifacts.hs | 211 +- bittide-experiments/src/Bittide/Hitl.hs | 541 +-- bittide-experiments/src/Bittide/Plot.hs | 189 +- .../src/Bittide/Report/ClockControl.hs | 420 +-- bittide-experiments/src/Bittide/Simulate.hs | 272 +- .../src/Bittide/Simulate/Config.hs | 355 +- .../src/Bittide/Simulate/ElasticBuffer.hs | 13 +- .../src/Bittide/Simulate/Time.hs | 14 +- .../src/Bittide/Simulate/Topology.hs | 242 +- .../src/Bittide/Simulate/TunableClockGen.hs | 24 +- bittide-experiments/src/Bittide/Topology.hs | 1625 +++++---- .../tests/Tests/Bittide/Simulate.hs | 38 +- bittide-experiments/tests/doctests.hs | 4 +- bittide-experiments/tests/unittests.hs | 12 +- bittide-extra/src/Bittide/Extra/Maybe.hs | 51 +- bittide-extra/src/Bittide/Extra/Wishbone.hs | 117 +- bittide-extra/src/Clash/Sized/Vector/Extra.hs | 3030 ++++++++++++++++- bittide-extra/src/Numeric/Extra.hs | 23 +- bittide-extra/tests/doctests/Main.hs | 2 +- bittide-extra/tests/unittests/Main.hs | 18 +- .../tests/unittests/Tests/Numeric/Extra.hs | 35 +- bittide-instances/exe/clash/Main.hs | 4 +- .../exe/post-board-test-extended/Main.hs | 16 +- .../exe/post-fullMeshSwCcTest/Main.hs | 80 +- .../exe/post-vex-riscv-test/Main.hs | 97 +- .../src/Bittide/Instances/Domains.hs | 96 +- .../src/Bittide/Instances/Hacks.hs | 58 +- .../src/Bittide/Instances/Hitl/BoardTest.hs | 133 +- .../src/Bittide/Instances/Hitl/FincFdec.hs | 161 +- .../Bittide/Instances/Hitl/FullMeshHwCc.hs | 452 +-- .../Bittide/Instances/Hitl/FullMeshSwCc.hs | 630 ++-- .../Bittide/Instances/Hitl/HwCcTopologies.hs | 876 +++-- .../src/Bittide/Instances/Hitl/IlaPlot.hs | 854 ++--- .../Instances/Hitl/LinkConfiguration.hs | 167 +- .../Instances/Hitl/Post/BoardTestExtended.hs | 39 +- .../Instances/Hitl/Post/PostProcess.hs | 60 +- .../src/Bittide/Instances/Hitl/Setup.hs | 99 +- .../Bittide/Instances/Hitl/SyncInSyncOut.hs | 180 +- .../Bittide/Instances/Hitl/Tcl/ExtraProbes.hs | 35 +- .../src/Bittide/Instances/Hitl/Tests.hs | 58 +- .../Bittide/Instances/Hitl/Transceivers.hs | 121 +- .../src/Bittide/Instances/Hitl/VexRiscv.hs | 163 +- .../src/Bittide/Instances/Pnr/Calendar.hs | 21 +- .../src/Bittide/Instances/Pnr/ClockControl.hs | 2 +- .../src/Bittide/Instances/Pnr/Counter.hs | 10 +- .../Bittide/Instances/Pnr/ElasticBuffer.hs | 10 +- .../src/Bittide/Instances/Pnr/Ethernet.hs | 240 +- .../Instances/Pnr/ProcessingElement.hs | 50 +- .../Bittide/Instances/Pnr/ScatterGather.hs | 98 +- .../src/Bittide/Instances/Pnr/Si539xSpi.hs | 149 +- .../Bittide/Instances/Pnr/StabilityChecker.hs | 8 +- .../src/Bittide/Instances/Pnr/Synchronizer.hs | 7 +- .../src/Paths/Bittide/Instances.hs | 8 +- bittide-instances/src/Project/FilePath.hs | 84 +- .../tests/Tests/OverflowResistantDiff.hs | 175 +- bittide-instances/tests/Wishbone/Axi.hs | 94 +- bittide-instances/tests/Wishbone/DnaPortE2.hs | 46 +- bittide-instances/tests/Wishbone/Time.hs | 63 +- bittide-instances/tests/doctests.hs | 4 +- bittide-instances/tests/unittests.hs | 15 +- bittide-shake/exe/Main.hs | 419 +-- bittide-shake/src/Clash/Shake/Extra.hs | 45 +- bittide-shake/src/Clash/Shake/Flags.hs | 53 +- bittide-shake/src/Clash/Shake/Vivado.hs | 164 +- bittide-shake/src/Development/Shake/Extra.hs | 2 +- bittide-shake/src/Paths/Bittide/Shake.hs | 8 +- bittide-shake/tests/doctests.hs | 4 +- bittide-tools/clockcontrol/plot/Main.hs | 980 +++--- bittide-tools/clockcontrol/sim/src/Domain.hs | 12 +- bittide-tools/clockcontrol/sim/src/Main.hs | 95 +- bittide-tools/hitl/config-gen/Main.hs | 64 +- bittide-tools/program/stream/Main.hs | 4 +- bittide/src/Bittide/Arithmetic/Ppm.hs | 17 +- bittide/src/Bittide/Arithmetic/Time.hs | 103 +- bittide/src/Bittide/Axi4.hs | 628 ++-- bittide/src/Bittide/Axi4/Internal.hs | 254 +- bittide/src/Bittide/Calendar.hs | 542 +-- bittide/src/Bittide/ClockControl.hs | 267 +- bittide/src/Bittide/ClockControl/Callisto.hs | 187 +- .../Bittide/ClockControl/Callisto/Types.hs | 248 +- .../src/Bittide/ClockControl/Callisto/Util.hs | 58 +- .../ClockControl/Foreign/Rust/Callisto.hs | 9 +- .../src/Bittide/ClockControl/Foreign/Sizes.hs | 359 +- .../Bittide/ClockControl/ParseRegisters.hs | 58 +- bittide/src/Bittide/ClockControl/Registers.hs | 53 +- bittide/src/Bittide/ClockControl/Si5391A.hs | 1717 +++++----- bittide/src/Bittide/ClockControl/Si5395J.hs | 2386 ++++++------- bittide/src/Bittide/ClockControl/Si539xSpi.hs | 419 +-- .../Bittide/ClockControl/StabilityChecker.hs | 59 +- bittide/src/Bittide/Counter.hs | 209 +- bittide/src/Bittide/DoubleBufferedRam.hs | 379 ++- bittide/src/Bittide/ElasticBuffer.hs | 69 +- bittide/src/Bittide/Ethernet/Mac.hs | 419 ++- bittide/src/Bittide/Link.hs | 304 +- bittide/src/Bittide/Node.hs | 111 +- bittide/src/Bittide/ProcessingElement.hs | 63 +- .../ProcessingElement/DeviceTreeCompiler.hs | 24 +- .../ProcessingElement/ProgramStream.hs | 99 +- .../src/Bittide/ProcessingElement/ReadElf.hs | 48 +- bittide/src/Bittide/ProcessingElement/Util.hs | 92 +- bittide/src/Bittide/ScatterGather.hs | 182 +- bittide/src/Bittide/SharedTypes.hs | 112 +- bittide/src/Bittide/Switch.hs | 92 +- bittide/src/Bittide/Transceiver.hs | 607 ++-- bittide/src/Bittide/Transceiver/Cdc.hs | 47 +- bittide/src/Bittide/Transceiver/Comma.hs | 24 +- bittide/src/Bittide/Transceiver/Prbs.hs | 114 +- .../src/Bittide/Transceiver/ResetManager.hs | 132 +- bittide/src/Bittide/Transceiver/WordAlign.hs | 114 +- bittide/src/Bittide/Wishbone.hs | 466 +-- bittide/src/Clash/Cores/Extra.hs | 200 +- bittide/src/Clash/Cores/UART/Extra.hs | 44 +- bittide/src/Clash/Cores/Xilinx/Extra.hs | 76 +- bittide/src/Clash/Cores/Xilinx/GTH.hs | 1 + .../src/Clash/Cores/Xilinx/GTH/BlackBoxes.hs | 412 ++- .../src/Clash/Cores/Xilinx/GTH/Internal.hs | 60 +- .../Cores/Xilinx/Xpm/Cdc/Handshake/Extra.hs | 28 +- bittide/src/Clash/Explicit/Reset/Extra.hs | 27 +- bittide/src/Clash/Sized/Extra.hs | 15 +- bittide/src/Data/Constraint/Nat/Extra.hs | 78 +- bittide/src/System/IO/Temp/Extra.hs | 11 +- bittide/tests/Tests/Axi4.hs | 221 +- bittide/tests/Tests/Axi4/Generators.hs | 49 +- bittide/tests/Tests/Axi4/Properties.hs | 204 +- bittide/tests/Tests/Axi4/Types.hs | 62 +- bittide/tests/Tests/Calendar.hs | 489 +-- bittide/tests/Tests/ClockControl/Si539xSpi.hs | 48 +- bittide/tests/Tests/Counter.hs | 24 +- bittide/tests/Tests/DoubleBufferedRam.hs | 915 +++-- bittide/tests/Tests/ElasticBuffer.hs | 190 +- bittide/tests/Tests/Haxioms.hs | 9 +- bittide/tests/Tests/Link.hs | 735 ++-- .../tests/Tests/ProcessingElement/ReadElf.hs | 484 +-- bittide/tests/Tests/ScatterGather.hs | 339 +- bittide/tests/Tests/Shared.hs | 187 +- bittide/tests/Tests/StabilityChecker.hs | 40 +- bittide/tests/Tests/Switch.hs | 100 +- bittide/tests/Tests/Transceiver.hs | 389 ++- bittide/tests/Tests/Transceiver/Prbs.hs | 54 +- bittide/tests/Tests/Transceiver/WordAlign.hs | 78 +- bittide/tests/Tests/Wishbone.hs | 293 +- bittide/tests/UnitTests.hs | 61 +- bittide/tests/doctests.hs | 2 +- 143 files changed, 18726 insertions(+), 12819 deletions(-) diff --git a/bittide-experiments/src/Bittide/Github/Artifacts.hs b/bittide-experiments/src/Bittide/Github/Artifacts.hs index c6675ed1a..d6ba92d61 100644 --- a/bittide-experiments/src/Bittide/Github/Artifacts.hs +++ b/bittide-experiments/src/Bittide/Github/Artifacts.hs @@ -1,40 +1,49 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitPrelude #-} -module Bittide.Github.Artifacts - ( RunId - , ArtifactName - , ArtifactAccessError - , retrieveArtifact - ) where + +module Bittide.Github.Artifacts ( + RunId, + ArtifactName, + ArtifactAccessError, + retrieveArtifact, +) where import Control.Exception (throwIO) import Control.Monad (forM) -import Data.Aeson - ( FromJSON(..), Value(..), Result(..), (.:) - , fromJSON, withObject, withArray, decodeFileStrict - ) +import Data.Aeson ( + FromJSON (..), + Result (..), + Value (..), + decodeFileStrict, + fromJSON, + withArray, + withObject, + (.:), + ) import Data.Map.Strict (Map) import Network.HTTP.Conduit (requestHeaders) -import Network.HTTP.Simple - ( JSONException(..) - , getResponseBody, httpJSONEither, parseRequest, getResponseStatus - ) +import Network.HTTP.Simple ( + JSONException (..), + getResponseBody, + getResponseStatus, + httpJSONEither, + parseRequest, + ) import Network.HTTP.Types.Header (hUserAgent) -import Network.HTTP.Types.Status (Status(..)) +import Network.HTTP.Types.Status (Status (..)) import System.Directory (createDirectoryIfMissing, listDirectory) -import System.Environment (lookupEnv, getProgName) +import System.Environment (getProgName, lookupEnv) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import System.Process (callCommand, callProcess) -import qualified Data.Map.Strict as Map (fromList, lookup) -import qualified Data.ByteString.Char8 as ByteString (pack) -import qualified Data.Text as Text (unpack) -import qualified Data.Vector as Vector (toList) +import Data.ByteString.Char8 qualified as ByteString (pack) +import Data.Map.Strict qualified as Map (fromList, lookup) +import Data.Text qualified as Text (unpack) +import Data.Vector qualified as Vector (toList) -- | The environment variable used to share the artifact access token. accessTokenEnvVar :: String @@ -46,8 +55,12 @@ bittideRepo = "bittide/bittide-hardware" -- | Offers the artifacts list of a given run via the Github API. githubApiArtifacts :: String -> String -> String -githubApiArtifacts repo run = "https://api.github.com/repos/" - <> repo <> "/actions/runs/" <> run <> "/artifacts?per_page=100" +githubApiArtifacts repo run = + "https://api.github.com/repos/" + <> repo + <> "/actions/runs/" + <> run + <> "/artifacts?per_page=100" -- | The unique identifier of the Github Action run. type RunId = String @@ -55,11 +68,12 @@ type RunId = String -- | The name of the artifact to be downloaded. type ArtifactName = String --- | Everything that can go wrong while trying to download an artifact --- from the Bittide Github repository with 'retrieveArtifact' that has --- its origin on some invalid user input passed to 'retrieveArtifact'. -data ArtifactAccessError = - NoAccessToken +{- | Everything that can go wrong while trying to download an artifact +from the Bittide Github repository with 'retrieveArtifact' that has +its origin on some invalid user input passed to 'retrieveArtifact'. +-} +data ArtifactAccessError + = NoAccessToken | InvalidAccessToken | RunNotFound RunId | ArtifactNotFound RunId ArtifactName @@ -68,18 +82,27 @@ instance Show ArtifactAccessError where show = \case NoAccessToken -> "No access token found. A valid access token must be set via\n" - <> "the " <> accessTokenEnvVar <> " environment variable." + <> "the " + <> accessTokenEnvVar + <> " environment variable." InvalidAccessToken -> "The provided access token has no access to the Bittide artifacts." RunNotFound runId -> - "Invalid run ID \"" <> runId <> "\". Cannot access the data for\n" + "Invalid run ID \"" + <> runId + <> "\". Cannot access the data for\n" <> "the provided ID." ArtifactNotFound runId artifactName -> - "There is no artifact named \"" <> artifactName <> "\" for the\n" - <> "run with ID " <> runId <> "." + "There is no artifact named \"" + <> artifactName + <> "\" for the\n" + <> "run with ID " + <> runId + <> "." --- | A newtype wrapper for extracting the "artifact name -> download --- url" mapping of a run via the Github API. +{- | A newtype wrapper for extracting the "artifact name -> download +url" mapping of a run via the Github API. +-} newtype ArtifactDownloadUrl = ArtifactDownloadUrl (Map String String) instance FromJSON ArtifactDownloadUrl where @@ -99,69 +122,79 @@ newtype CurlResponseMessage = CurlResponseMessage String instance FromJSON CurlResponseMessage where parseJSON = - (CurlResponseMessage . Text.unpack <$>) . - withObject "root" (.: "message") + (CurlResponseMessage . Text.unpack <$>) + . withObject "root" (.: "message") --- | Retrieve the artifact with the given name for the given run id --- and save it at the provided location. An 'ArtifactAccessError' is --- returned on failure with respect to the provided arguments. If the --- arguments are valid, but there is some external problem with the --- utilized process, then that error gets reported via an exception --- instead. +{- | Retrieve the artifact with the given name for the given run id +and save it at the provided location. An 'ArtifactAccessError' is +returned on failure with respect to the provided arguments. If the +arguments are valid, but there is some external problem with the +utilized process, then that error gets reported via an exception +instead. +-} retrieveArtifact :: RunId -> ArtifactName -> FilePath -> IO (Maybe ArtifactAccessError) retrieveArtifact runId artifactName destination = do appName <- getProgName request <- parseRequest $ githubApiArtifacts bittideRepo runId - response <- httpJSONEither request - { -- Github requires to set the User Agent header, as the request - -- will always be rejected otherwise - requestHeaders = [(hUserAgent, ByteString.pack appName)] - } + response <- + httpJSONEither + request + { -- Github requires to set the User Agent header, as the request + -- will always be rejected otherwise + requestHeaders = [(hUserAgent, ByteString.pack appName)] + } case getResponseBody response of - Left err@(JSONParseException {}) -> throwIO err + Left err@(JSONParseException{}) -> throwIO err Left err@(JSONConversionException _ resp _) -> - if statusCode (getResponseStatus resp ) == 404 - then return $ Just $ RunNotFound runId - else throwIO err + if statusCode (getResponseStatus resp) == 404 + then return $ Just $ RunNotFound runId + else throwIO err Right (ArtifactDownloadUrl downloadUrls) -> do case Map.lookup artifactName downloadUrls of Nothing -> return $ Just $ ArtifactNotFound runId artifactName - Just downloadUrl -> lookupEnv accessTokenEnvVar >>= \case - Nothing -> return $ Just NoAccessToken - Just accessToken -> - withSystemTempDirectory "retrieve-artifact" $ \path -> do - let file = path "artifact.zip" - putStrLn $ "Retrieving " <> artifactName <> ".zip" - putStrLn "---" - callCommand $ unwords - [ "curl" - , "--location" - , "--header", "\"authorization: Bearer " <> accessToken <> "\"" - , "--output", file - , downloadUrl - ] - putStr "---" - -- if the downloaded file is a JSON instead of zip, then - -- something went wrong - decodeFileStrict file >>= \case - Just jsonValue -> do - putStrLn " Failed." - if case fromJSON jsonValue of - Success (CurlResponseMessage msg) -> - msg == "Bad credentials" - _ -> False - then return $ Just InvalidAccessToken - else do - req <- parseRequest downloadUrl - throwIO $ JSONConversionException - req (jsonValue <$ response) "curl download failed" - Nothing -> do - putStrLn " Success." - callProcess "unzip" ["-q", file, "-d", path] - callProcess "rm" [file] - createDirectoryIfMissing True destination - (listDirectory path >>=) $ mapM_ $ \x -> do - callProcess "rm" ["-Rf", destination x] - callProcess "mv" [path x, destination x] - return Nothing + Just downloadUrl -> + lookupEnv accessTokenEnvVar >>= \case + Nothing -> return $ Just NoAccessToken + Just accessToken -> + withSystemTempDirectory "retrieve-artifact" $ \path -> do + let file = path "artifact.zip" + putStrLn $ "Retrieving " <> artifactName <> ".zip" + putStrLn "---" + callCommand $ + unwords + [ "curl" + , "--location" + , "--header" + , "\"authorization: Bearer " <> accessToken <> "\"" + , "--output" + , file + , downloadUrl + ] + putStr "---" + -- if the downloaded file is a JSON instead of zip, then + -- something went wrong + decodeFileStrict file >>= \case + Just jsonValue -> do + putStrLn " Failed." + if case fromJSON jsonValue of + Success (CurlResponseMessage msg) -> + msg == "Bad credentials" + _ -> False + then return $ Just InvalidAccessToken + else do + req <- parseRequest downloadUrl + throwIO $ + JSONConversionException + req + (jsonValue <$ response) + "curl download failed" + Nothing -> do + putStrLn " Success." + callProcess "unzip" ["-q", file, "-d", path] + callProcess "rm" [file] + createDirectoryIfMissing True destination + (listDirectory path >>=) $ mapM_ $ \x -> do + callProcess "rm" ["-Rf", destination x] + callProcess "mv" [path x, destination x] + return Nothing diff --git a/bittide-experiments/src/Bittide/Hitl.hs b/bittide-experiments/src/Bittide/Hitl.hs index 655a54cae..a0202916f 100644 --- a/bittide-experiments/src/Bittide/Hitl.hs +++ b/bittide-experiments/src/Bittide/Hitl.hs @@ -1,186 +1,198 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --- | Tooling to define hardware-in-the-loop (HITL) tests. HITL tests are FPGA instances --- that incorporate a [VIO](https://www.xilinx.com/products/intellectual-property/vio.html) --- to start tests and communicate test statusses. In practise, developers writing --- HITL tests should make sure to do two things: --- --- 1. They should incorporate a HITL VIO in their design. See 'hitlVio' and 'hitlVioBool'. --- --- 2. They should define the targets to run the tests against (multiple FPGAs, or just --- one), and with which inputs/parameters the tests should be run. See 'HitlTests' --- for examples, together with it's convenience functions 'testsFromEnum', --- 'noConfigTest', 'allFpgas', and 'singleFpga'. --- --- Tests are collected in @bin/Hitl.hs@. This command line utility can create --- configuration files that can be processed by @HardwareTest.tcl@, and in turn --- configure FPGAs appropriately. --- --- === __Manual test definition__ --- If you cannot reasonably use `tests` to define your tests, you can manually --- write a configuration file. This file should be a YAML file as specified in --- @HardwareTest.tcl@. In order for Shake to find it, it must still be defined --- in @bin/Hitl.hs@, including the definition using @loadConfig@. This will load --- the configuration from a file in @bittide-instances\/data\/test_configs@. --- --- === __Flow overview__ --- --- 1. User calls @shake \:test@ to run HITL tests. --- 2. Shake calls @cabal run bittide-instances:hitl write \@ to generate --- a HITL configuration for @\@. This will write a file @\.yml@ --- to @_build/hitl@. --- 3. Shake builds a bitstream, programs the FPGA, and runs the HITL tests using --- the configuration file and @HardwareTest.tcl@. --- -module Bittide.Hitl - ( HitlTests - , HitlTestsWithPostProcData - , MayHavePostProcData(..) - , NoPostProcData(..) - , Probes - , FpgaIndex - , TestName +{- | Tooling to define hardware-in-the-loop (HITL) tests. HITL tests are FPGA instances +that incorporate a [VIO](https://www.xilinx.com/products/intellectual-property/vio.html) +to start tests and communicate test statusses. In practise, developers writing +HITL tests should make sure to do two things: + + 1. They should incorporate a HITL VIO in their design. See 'hitlVio' and 'hitlVioBool'. + + 2. They should define the targets to run the tests against (multiple FPGAs, or just + one), and with which inputs/parameters the tests should be run. See 'HitlTests' + for examples, together with it's convenience functions 'testsFromEnum', + 'noConfigTest', 'allFpgas', and 'singleFpga'. + +Tests are collected in @bin/Hitl.hs@. This command line utility can create +configuration files that can be processed by @HardwareTest.tcl@, and in turn +configure FPGAs appropriately. + +=== __Manual test definition__ +If you cannot reasonably use `tests` to define your tests, you can manually +write a configuration file. This file should be a YAML file as specified in +@HardwareTest.tcl@. In order for Shake to find it, it must still be defined +in @bin/Hitl.hs@, including the definition using @loadConfig@. This will load +the configuration from a file in @bittide-instances\/data\/test_configs@. + +=== __Flow overview__ + + 1. User calls @shake \:test@ to run HITL tests. + 2. Shake calls @cabal run bittide-instances:hitl write \@ to generate + a HITL configuration for @\@. This will write a file @\.yml@ + to @_build/hitl@. + 3. Shake builds a bitstream, programs the FPGA, and runs the HITL tests using + the configuration file and @HardwareTest.tcl@. +-} +module Bittide.Hitl ( + HitlTests, + HitlTestsWithPostProcData, + MayHavePostProcData (..), + NoPostProcData (..), + Probes, + FpgaIndex, + TestName, -- * Test construction convenience functions - , allFpgas, singleFpga - , testsFromEnum, noConfigTest + allFpgas, + singleFpga, + testsFromEnum, + noConfigTest, -- * Test definition - , Done, Success - , hitlVio - , hitlVioBool + Done, + Success, + hitlVio, + hitlVioBool, -- * Packing - , packAndEncode - ) - where + packAndEncode, +) +where import Prelude -import Clash.Prelude - ( BitPack(BitSize), Index, KnownDomain, natToInteger, pack - , Vec((:>), Nil) - ) +import Clash.Prelude ( + BitPack (BitSize), + Index, + KnownDomain, + Vec (Nil, (:>)), + natToInteger, + pack, + ) import Clash.Cores.Xilinx.VIO (vioProbe) -import Data.Aeson (ToJSON(toJSON), Value(Number), object, (.=)) -import Data.Aeson.Encode.Pretty - ( Config(..), NumberFormat(..), encodePretty', defConfig ) +import Data.Aeson (ToJSON (toJSON), Value (Number), object, (.=)) +import Data.Aeson.Encode.Pretty ( + Config (..), + NumberFormat (..), + defConfig, + encodePretty', + ) import Data.Aeson.Text (encodeToTextBuilder) import Data.Map (Map) import Data.Maybe (isJust) import Data.Text (Text) -import GHC.Exts (IsList(fromList, toList)) +import GHC.Exts (IsList (fromList, toList)) import GHC.Generics (Generic) import Numeric.Natural (Natural) -import qualified Clash.Prelude as P -import qualified Clash.Sized.Internal.BitVector as BitVector -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy.Char8 as LazyByteString -import qualified Data.Map as Map -import qualified Data.Text as Text +import Clash.Prelude qualified as P +import Clash.Sized.Internal.BitVector qualified as BitVector +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Map qualified as Map +import Data.Text qualified as Text --- | FPGA index pointing to a specific FPGA in the Bittide demo rig. This will be --- replaced by proper device identifiers in the future. +{- | FPGA index pointing to a specific FPGA in the Bittide demo rig. This will be +replaced by proper device identifiers in the future. +-} type FpgaIndex = Index 8 type TestName = Text --- | A collection of (named) tests that should performed with hardware in the --- loop. Each test defines what data a specific FPGA should receive (see "Probes"). --- Furthermore, some additional data can be provided, if required by subsequent --- post-processing steps (which must have a 'ToJSON' instance). --- --- === __Example: Test without configuration__ --- A test that runs for all FPGAs, and does not require any input: --- --- > tests :: HitlTests () --- > tests = noConfigTest allFpgas --- --- This must be accompanied by a @hitlVioBool@ in the design. --- --- === __Example: Test based on an enum__ --- A test that runs for each constructor of an enum: --- --- > data ABC = A | B | C --- > --- > tests :: HitlTests ABC --- > tests = testsFromEnum allFpgas --- --- This must be accompanied by a @hitlVio \@ABC@ in the design. --- --- === __Example: Test with custom configuration and no post processing data__ --- A test that runs on specific FPGAs, and requires a (hypothetical) 8-bit number --- indicating the \"number of stages\" to be set on each FPGA: --- --- > type NumberOfStages = Unsigned 8 --- > --- > tests :: HitlTests NumberOfStages --- > tests = Map.fromList --- > [ ( "Twelve stages on FPGA 2 and 5" --- > , ( [ (2, 12) --- > , (5, 12) --- > ] --- > , NoPostProcData --- > ) --- > ) --- > , ( "Six stages on FPGA 3, seven on FPGA 4" --- > , ( [ (3, 6) --- > , (4, 7) --- > ] --- > , NoPostProcData --- > ) --- > ) --- > ] --- --- This must be accompanied by a @hitlVio \@NumberOfStages@ in the design. --- --- === __Example: Test with custom configuration and post processing data__ --- A test that runs on specific FPGAs, and requires a (hypothetical) 8-bit number --- indicating the \"number of stages\" to be set on each FPGA. Additionally, --- some 'Int' constant gets fixed for each test, which will be written to --- the generated config files, but is not passed to the HITL test: --- --- > type NumberOfStages = Unsigned 8 --- > --- > tests :: HitlTests NumberOfStages Int --- > tests = Map.fromList --- > [ ( "Twelve stages on FPGA 2 and 5" --- > , ( [ (2, 12) --- > , (5, 12) --- > ] --- > , 42 --- > ) --- > ) --- > , ( "Six stages on FPGA 3, seven on FPGA 4" --- > , ( [ (3, 6) --- > , (4, 7) --- > ] --- > , 13 --- > ) --- > ) --- > ] --- --- This must be accompanied by a @hitlVio \@NumberOfStages@ in the design. --- +{- | A collection of (named) tests that should performed with hardware in the +loop. Each test defines what data a specific FPGA should receive (see "Probes"). +Furthermore, some additional data can be provided, if required by subsequent +post-processing steps (which must have a 'ToJSON' instance). + +=== __Example: Test without configuration__ +A test that runs for all FPGAs, and does not require any input: + +> tests :: HitlTests () +> tests = noConfigTest allFpgas + +This must be accompanied by a @hitlVioBool@ in the design. + +=== __Example: Test based on an enum__ +A test that runs for each constructor of an enum: + +> data ABC = A | B | C +> +> tests :: HitlTests ABC +> tests = testsFromEnum allFpgas + +This must be accompanied by a @hitlVio \@ABC@ in the design. + +=== __Example: Test with custom configuration and no post processing data__ +A test that runs on specific FPGAs, and requires a (hypothetical) 8-bit number +indicating the \"number of stages\" to be set on each FPGA: + +> type NumberOfStages = Unsigned 8 +> +> tests :: HitlTests NumberOfStages +> tests = Map.fromList +> [ ( "Twelve stages on FPGA 2 and 5" +> , ( [ (2, 12) +> , (5, 12) +> ] +> , NoPostProcData +> ) +> ) +> , ( "Six stages on FPGA 3, seven on FPGA 4" +> , ( [ (3, 6) +> , (4, 7) +> ] +> , NoPostProcData +> ) +> ) +> ] + +This must be accompanied by a @hitlVio \@NumberOfStages@ in the design. + +=== __Example: Test with custom configuration and post processing data__ +A test that runs on specific FPGAs, and requires a (hypothetical) 8-bit number +indicating the \"number of stages\" to be set on each FPGA. Additionally, +some 'Int' constant gets fixed for each test, which will be written to +the generated config files, but is not passed to the HITL test: + +> type NumberOfStages = Unsigned 8 +> +> tests :: HitlTests NumberOfStages Int +> tests = Map.fromList +> [ ( "Twelve stages on FPGA 2 and 5" +> , ( [ (2, 12) +> , (5, 12) +> ] +> , 42 +> ) +> ) +> , ( "Six stages on FPGA 3, seven on FPGA 4" +> , ( [ (3, 6) +> , (4, 7) +> ] +> , 13 +> ) +> ) +> ] + +This must be accompanied by a @hitlVio \@NumberOfStages@ in the design. +-} type HitlTestsWithPostProcData a b = Map TestName (Probes a, b) -- | The type synonym for tests without additional post processing data. type HitlTests a = HitlTestsWithPostProcData a NoPostProcData --- | A list of values to set on a specific FPGA. See convenience methods --- 'allFpgas' and 'singleFpga'. +{- | A list of values to set on a specific FPGA. See convenience methods +'allFpgas' and 'singleFpga'. +-} type Probes a = [(FpgaIndex, a)] -- | A class for extracting optional post processing data from a test. @@ -195,10 +207,11 @@ class MayHavePostProcData b c where instance MayHavePostProcData a a where mGetPPD = fmap (Just . snd) --- | A custom data type for indicating tests without any additional --- post processing data with a custom 'ToJSON' instance. This is --- required, because the TCL -> YAML interface does not support empty --- lists or empty objects. +{- | A custom data type for indicating tests without any additional +post processing data with a custom 'ToJSON' instance. This is +required, because the TCL -> YAML interface does not support empty +lists or empty objects. +-} data NoPostProcData = NoPostProcData instance ToJSON NoPostProcData where toJSON _ = Aeson.Null @@ -206,61 +219,65 @@ instance MayHavePostProcData NoPostProcData a where mGetPPD = const [] -- | Set one specific value on all FPGAs allFpgas :: a -> Probes a -allFpgas a = (, a) <$> [0..] +allFpgas a = (,a) <$> [0 ..] -- | Perform a test on just a single FPGA singleFpga :: FpgaIndex -> a -> Probes a singleFpga ix a = [(ix, a)] --- | Define a 'HitlTests' for a test that does not accept any input. Use of 'noConfigTest' --- should be paired with 'hitlVioBool'. --- --- Example invocation: --- --- > tests :: HitlTests () --- > tests = noConfigTest allFpgas +{- | Define a 'HitlTests' for a test that does not accept any input. Use of 'noConfigTest' +should be paired with 'hitlVioBool'. + +Example invocation: + +> tests :: HitlTests () +> tests = noConfigTest allFpgas +-} noConfigTest :: TestName -> (forall a. a -> Probes a) -> HitlTests () noConfigTest nm f = Map.singleton nm (f (), NoPostProcData) --- | Generate a set of tests from an enum. E.g., if you defined a data type looking --- like: --- --- > data ABC = A | B | C --- --- You can use the following to generate a test config that runs a test for each --- constructor of @ABC@: --- --- > tests :: HitlTests ABC --- > tests = testsFromEnum allFpgas --- +{- | Generate a set of tests from an enum. E.g., if you defined a data type looking +like: + +> data ABC = A | B | C + +You can use the following to generate a test config that runs a test for each +constructor of @ABC@: + +> tests :: HitlTests ABC +> tests = testsFromEnum allFpgas +-} testsFromEnum :: (Show a, Bounded a, Enum a) => (a -> Probes a) -> HitlTests a -testsFromEnum f = Map.fromList - $ map (\a -> (Text.pack (show a), (f a, NoPostProcData))) [minBound..] +testsFromEnum f = + Map.fromList $ + map (\a -> (Text.pack (show a), (f a, NoPostProcData))) [minBound ..] -- | A list, but with a custom "ToJSON" instance to work around Vivado issues newtype PackedList a = PackedList [a] --- | XXX: Custom "ToJSON" instance for "PackedList" that converts an empty --- "PackedList" into a 'Aeson.Null' to accommodate Vivado's poorly --- implemented JSON/YAML parser. -instance ToJSON a => ToJSON (PackedList a) where +{- | XXX: Custom "ToJSON" instance for "PackedList" that converts an empty + "PackedList" into a 'Aeson.Null' to accommodate Vivado's poorly + implemented JSON/YAML parser. +-} +instance (ToJSON a) => ToJSON (PackedList a) where toJSON (PackedList []) = Aeson.Null toJSON (PackedList l) = toJSON l --- | A map from a probe name to a (binary) value with a custom "ToJSON" instance --- to work around Vivado issues. +{- | A map from a probe name to a (binary) value with a custom "ToJSON" instance +to work around Vivado issues. +-} newtype PackedProbes = PackedProbes (Map Text Natural) --- | XXX: Custom "ToJSON" instance for "PackedProbes" that converts an empty --- "PackedProbes" into a 'Aeson.Null' to accommodate Vivado's poorly --- implemented JSON/YAML parser. +{- | XXX: Custom "ToJSON" instance for "PackedProbes" that converts an empty + "PackedProbes" into a 'Aeson.Null' to accommodate Vivado's poorly + implemented JSON/YAML parser. +-} instance ToJSON PackedProbes where toJSON (PackedProbes []) = Aeson.Null toJSON (PackedProbes l) = toJSON l -- | See "PackedTests" -newtype PackedTargetRef - = ByIndex { index :: Integer } +newtype PackedTargetRef = ByIndex {index :: Integer} deriving (Generic, ToJSON) -- | See "PackedTests" @@ -277,21 +294,24 @@ data PackedTest a = PackedTest } deriving (Generic, ToJSON) --- | Intermediate representation of "HitlTests". There to provide trivial instances --- of "ToJSON". +{- | Intermediate representation of "HitlTests". There to provide trivial instances +of "ToJSON". +-} data PackedTests a = PackedTests { defaults :: PackedProbes , tests :: Map Text (PackedTest a) } -instance ToJSON a => ToJSON (PackedTests a) where - toJSON (PackedTests{defaults, tests}) = object - [ "defaults" .= object ["probes" .= defaults] - , "tests" .= toJSON tests - ] +instance (ToJSON a) => ToJSON (PackedTests a) where + toJSON (PackedTests{defaults, tests}) = + object + [ "defaults" .= object ["probes" .= defaults] + , "tests" .= toJSON tests + ] --- | Convert an \"unpacked\" "HitlTests" to a packed version. The packed version --- is convertible to JSON, which in turn can be interpreted by the @HardwareTest.tcl@. +{- | Convert an \"unpacked\" "HitlTests" to a packed version. The packed version +is convertible to JSON, which in turn can be interpreted by the @HardwareTest.tcl@. +-} toPacked :: forall a b. (BitPack a, ToJSON b) => @@ -300,65 +320,70 @@ toPacked :: toPacked hitlTests = PackedTests{defaults, tests} where bitSizeA = natToInteger @(BitSize a) - tests = fromList - [ (name, goProbes probes ppData) - | (name, (probes, ppData)) <- toList hitlTests - ] + tests = + fromList + [ (name, goProbes probes ppData) + | (name, (probes, ppData)) <- toList hitlTests + ] defaults -- If @a@ is a zero-width type, we don't want to generate any data probes | bitSizeA == 0 = PackedProbes [] - | otherwise = PackedProbes [("probe_test_data", 0)] + | otherwise = PackedProbes [("probe_test_data", 0)] - goProbes probes postproc = PackedTest - { targets = PackedList $ goTargetList probes - , .. - } + goProbes probes postproc = + PackedTest + { targets = PackedList $ goTargetList probes + , .. + } goTargetList probes | bitSizeA == 0 = - [PackedTarget - { target=ByIndex (toInteger id_) - , probes=PackedProbes [] - } | (id_, _) <- probes] - + [ PackedTarget + { target = ByIndex (toInteger id_) + , probes = PackedProbes [] + } + | (id_, _) <- probes + ] | otherwise = - [PackedTarget - { target=ByIndex (toInteger id_) - , probes=PackedProbes [("probe_test_data", BitVector.unsafeToNatural (pack dat))] - } | (id_, dat) <- probes - ] - --- | Convert a collection of named tests ("HitlTests") to a \"packed\" representation --- readable by our TCL test infrastructure. It will generate YAML/JSON that looks --- like: --- --- > defaults: --- > probes: --- > probe_test_data: 0 --- > --- > tests: --- > testname1: --- > targets: --- > - id: 0 --- > probes: --- > probe_test_data: --- > - id: 1 --- > probes: --- > probe_test_data: --- > ... --- > testname2: --- > ... --- + [ PackedTarget + { target = ByIndex (toInteger id_) + , probes = PackedProbes [("probe_test_data", BitVector.unsafeToNatural (pack dat))] + } + | (id_, dat) <- probes + ] + +{- | Convert a collection of named tests ("HitlTests") to a \"packed\" representation +readable by our TCL test infrastructure. It will generate YAML/JSON that looks +like: + +> defaults: +> probes: +> probe_test_data: 0 +> +> tests: +> testname1: +> targets: +> - id: 0 +> probes: +> probe_test_data: +> - id: 1 +> probes: +> probe_test_data: +> ... +> testname2: +> ... +-} packAndEncode :: forall a b. (BitPack a, ToJSON b) => HitlTestsWithPostProcData a b -> LazyByteString.ByteString -packAndEncode = encodePretty' - defConfig - { confNumFormat = Custom (encodeToTextBuilder . Number) - } - . toPacked +packAndEncode = + encodePretty' + defConfig + { confNumFormat = Custom (encodeToTextBuilder . Number) + } + . toPacked -- | Whether a test has been completed, see 'hitlVio'. type Done = Bool @@ -366,14 +391,15 @@ type Done = Bool -- | Whether a test has been completed successfully, see 'hitlVio'. type Success = Bool --- | Instantiate this VIO in a design you'd like to test with hardware in the --- loop. Its output is set to 'Nothing' if a test is not running, and will be --- set to 'Just' if it is. +{- | Instantiate this VIO in a design you'd like to test with hardware in the +loop. Its output is set to 'Nothing' if a test is not running, and will be +set to 'Just' if it is. +-} hitlVio :: - forall a dom . + forall a dom. ( KnownDomain dom , BitPack a - ) => + ) => -- | Default value for @a@. This is an artifact of this VIO internally representing -- the output value as two probes (\"valid\" and \"data\") to accommodate the -- TCL infrastructure. Hence, the actual value of the default doesn't matter: @@ -391,18 +417,21 @@ hitlVio :: -- | Test values supplied by the VIO. Test modules should export a symbol -- @tests :: HitlTests a@ that defines the data. P.Signal dom (Maybe a) -hitlVio dflt clk done success | natToInteger @(BitSize a) == 0 = - -- XXX: This branch is a workaround for 'vioProbe' not handling zero-width - -- ports properly. - P.mux start (pure (Just dflt)) (pure Nothing) +hitlVio dflt clk done success + | natToInteger @(BitSize a) == 0 = + -- XXX: This branch is a workaround for 'vioProbe' not handling zero-width + -- ports properly. + P.mux start (pure (Just dflt)) (pure Nothing) where start = P.setName @"vioHitlt" $ vioProbe ("probe_test_done" :> "probe_test_success" :> Nil) ("probe_test_start" :> Nil) - False clk done success - + False + clk + done + success hitlVio dflt clk done success = P.mux start (Just <$> dat) (pure Nothing) where @@ -411,14 +440,18 @@ hitlVio dflt clk done success = vioProbe ("probe_test_done" :> "probe_test_success" :> Nil) ("probe_test_start" :> "probe_test_data" :> Nil) - (False, dflt) clk done success - --- | Instantiate this VIO in a design you'd like to test with hardware in the --- loop. Its output is set to 'True' if a test is not running, and will be --- set to 'False' if it is. + (False, dflt) + clk + done + success + +{- | Instantiate this VIO in a design you'd like to test with hardware in the +loop. Its output is set to 'True' if a test is not running, and will be +set to 'False' if it is. +-} hitlVioBool :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => P.Clock dom -> -- | Should be asserted when a test is done. For sanity checking the TCL -- infrastructure, this must be *deasserted* when a test is not running. diff --git a/bittide-experiments/src/Bittide/Plot.hs b/bittide-experiments/src/Bittide/Plot.hs index e20e6660e..3e316028c 100644 --- a/bittide-experiments/src/Bittide/Plot.hs +++ b/bittide-experiments/src/Bittide/Plot.hs @@ -1,38 +1,49 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE ImplicitPrelude #-} -module Bittide.Plot - ( ReframingStage(..) - , fromRfState - , plot - , plotClocksFileName - , plotElasticBuffersFileName - ) where + +module Bittide.Plot ( + ReframingStage (..), + fromRfState, + plot, + plotClocksFileName, + plotElasticBuffersFileName, +) where import Clash.Prelude (KnownNat, Vec) import Clash.Sized.Vector qualified as Vec -import Data.Graph (edges) -import Data.List (foldl', transpose) +import Control.Monad (void) import Data.Aeson (ToJSON) import Data.Bifunctor (bimap) -import Control.Monad (void) +import Data.Graph (edges) +import Data.List (foldl', transpose) import System.FilePath (()) -import qualified Graphics.Matplotlib as MP (plot) -import Graphics.Matplotlib - ( Matplotlib, (%), (@@) - , file, xlabel, ylabel, o1, o2, mp, legend, axes, figure - ) - -import Bittide.ClockControl.StabilityChecker qualified as SC (StabilityIndication(..)) -import Bittide.ClockControl.Callisto (ReframingState(..)) +import Graphics.Matplotlib ( + Matplotlib, + axes, + figure, + file, + legend, + mp, + o1, + o2, + xlabel, + ylabel, + (%), + (@@), + ) +import Graphics.Matplotlib qualified as MP (plot) + +import Bittide.ClockControl.Callisto (ReframingState (..)) +import Bittide.ClockControl.StabilityChecker qualified as SC (StabilityIndication (..)) import Bittide.Topology --- | 'Bittide.ClockControl.Callisto.ReframingState' reduced to its --- stages. +{- | 'Bittide.ClockControl.Callisto.ReframingState' reduced to its +stages. +-} data ReframingStage = RSDetect | RSWait | RSDone deriving (Show) -- | Default name of the clocks plot file. @@ -45,19 +56,20 @@ plotElasticBuffersFileName = "elasticbuffers.pdf" fromRfState :: ReframingState -> ReframingStage fromRfState = \case - Detect {} -> RSDetect - Wait {} -> RSWait - Done {} -> RSDone + Detect{} -> RSDetect + Wait{} -> RSWait + Done{} -> RSDone plot :: (KnownNat n, ToJSON b, ToJSON t, ToJSON d) => - -- ^ constraints + -- \^ constraints + + -- | output directory for storing the resuts FilePath -> - -- ^ output directory for storing the resuts + -- | topology corresponding to the plot Topology n -> - -- ^ topology corresponding to the plot + -- | plot data Vec n [(t, b, ReframingStage, [(d, SC.StabilityIndication)])] -> - -- ^ plot data IO () plot dir graph = uncurry (matplotWrite dir) . Vec.unzip . Vec.imap plotDats @@ -65,56 +77,60 @@ plot dir graph = edgeCount = length $ edges $ topologyGraph graph plotDats i = - bimap - ( withLegend - . (@@ [o2 "label" $ fromEnum i]) - . uncurry MP.plot - . unzip - ) - ( foldPlots - . fmap ( -- Too many legend entries don't fit. We picked 20 by - -- simply observing when legend entries wouldn't fit - -- anymore. - if edgeCount <= 20 - then \(j, p) -> - withLegend $ p @@ [o2 "label" $ show i <> " ← " <> show j] - else snd - ) - . zip (filter (hasEdge graph i) [0,1..]) - . fmap plotEbData - . transpose - ) - . unzip - . fmap (\(a,b,c,d) -> ((a,b), ((a,c),) <$> d)) + bimap + ( withLegend + . (@@ [o2 "label" $ fromEnum i]) + . uncurry MP.plot + . unzip + ) + ( foldPlots + . fmap + ( -- Too many legend entries don't fit. We picked 20 by + -- simply observing when legend entries wouldn't fit + -- anymore. + if edgeCount <= 20 + then \(j, p) -> + withLegend $ p @@ [o2 "label" $ show i <> " ← " <> show j] + else snd + ) + . zip (filter (hasEdge graph i) [0, 1 ..]) + . fmap plotEbData + . transpose + ) + . unzip + . fmap (\(a, b, c, d) -> ((a, b), ((a, c),) <$> d)) withLegend = - ( @@ [ o2 "bbox_to_anchor" (1.01 :: Double, 1 :: Double) - , o2 "loc" "upper left" - ] - ) . (% legend) + ( @@ + [ o2 "bbox_to_anchor" (1.01 :: Double, 1 :: Double) + , o2 "loc" "upper left" + ] + ) + . (% legend) data Marking = Waiting | Stable | Settled | None deriving (Eq) --- | Plots the datacount of an elastic buffer and marks those parts of --- the plots that are reported to be stable/settled by the stability --- checker as well as the time frames at which the reframing detector --- is in the waiting state. +{- | Plots the datacount of an elastic buffer and marks those parts of +the plots that are reported to be stable/settled by the stability +checker as well as the time frames at which the reframing detector +is in the waiting state. +-} plotEbData :: (ToJSON t, ToJSON d) => [((t, ReframingStage), (d, SC.StabilityIndication))] -> Matplotlib plotEbData xs = foldPlots markedIntervals % ebPlot where - mGr = (@@ [ o1 "g-", o2 "linewidth" (8 :: Int)]) -- green marking - mBl = (@@ [ o1 "b-", o2 "linewidth" (8 :: Int)]) -- blue marking - mRe = (@@ [ o1 "r-", o2 "linewidth" (8 :: Int)]) -- red marking + mGr = (@@ [o1 "g-", o2 "linewidth" (8 :: Int)]) -- green marking + mBl = (@@ [o1 "b-", o2 "linewidth" (8 :: Int)]) -- blue marking + mRe = (@@ [o1 "r-", o2 "linewidth" (8 :: Int)]) -- red marking ebPlot = uncurry MP.plot $ unzip ((\((t, _), (d, _)) -> (t, d)) <$> xs) mindMarking ys ms = \case Waiting -> (mRe, reverse ys) : ms - Stable -> (mBl, reverse ys) : ms + Stable -> (mBl, reverse ys) : ms Settled -> (mGr, reverse ys) : ms - None -> ms + None -> ms markedIntervals = (\(mark, ys) -> mark $ uncurry MP.plot $ unzip ys) @@ -122,44 +138,49 @@ plotEbData xs = foldPlots markedIntervals % ebPlot collectIntervals ((previous, ys), markings) [] = mindMarking ys markings previous - collectIntervals ((previous, ys), markings) (((t, mode), (d, sci)) : xr) = collectIntervals a' xr where current = case mode of - RSWait {} -> Waiting + RSWait{} -> Waiting _ | SC.settled sci -> Settled - | SC.stable sci -> Stable - | otherwise -> None + | SC.stable sci -> Stable + | otherwise -> None markings' = mindMarking ys markings previous - a' | current == previous = ((current, (t, d) : ys), markings ) - | current == None = ((None, [] ), markings') - | otherwise = ((current, [(t, d)] ), markings') + a' + | current == previous = ((current, (t, d) : ys), markings) + | current == None = ((None, []), markings') + | otherwise = ((current, [(t, d)]), markings') --- | Folds the vectors of generated plots and writes the results to --- the disk. +{- | Folds the vectors of generated plots and writes the results to +the disk. +-} matplotWrite :: - KnownNat n => + (KnownNat n) => + -- | output directory FilePath -> - -- ^ output directory + -- | clock plots Vec n Matplotlib -> - -- ^ clock plots + -- | elastic buffer plots Vec n Matplotlib -> - -- ^ elastic buffer plots IO () matplotWrite dir clockDats ebDats = do - void $ file (dir plotClocksFileName) $ constrained - ( xlabel "Time (fs)" - % ylabel "Relative period (fs) [0 = ideal frequency]" - % foldPlots (reverse $ Vec.toList clockDats) - ) - void $ file (dir plotElasticBuffersFileName) $ constrained - ( xlabel "Time (fs)" - % foldPlots (Vec.toList ebDats) - ) + void $ + file (dir plotClocksFileName) $ + constrained + ( xlabel "Time (fs)" + % ylabel "Relative period (fs) [0 = ideal frequency]" + % foldPlots (reverse $ Vec.toList clockDats) + ) + void $ + file (dir plotElasticBuffersFileName) $ + constrained + ( xlabel "Time (fs)" + % foldPlots (Vec.toList ebDats) + ) where constrained = ((figure @@ [o2 "layout" "constrained"] % axes) %) diff --git a/bittide-experiments/src/Bittide/Report/ClockControl.hs b/bittide-experiments/src/Bittide/Report/ClockControl.hs index d956be48e..99434d142 100644 --- a/bittide-experiments/src/Bittide/Report/ClockControl.hs +++ b/bittide-experiments/src/Bittide/Report/ClockControl.hs @@ -1,23 +1,29 @@ +{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE ImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -module Bittide.Report.ClockControl - ( generateReport - , checkDependencies - , checkIntermediateResults - ) where + +module Bittide.Report.ClockControl ( + generateReport, + checkDependencies, + checkIntermediateResults, +) where import Data.Bool (bool) import Data.List (intercalate) import System.Directory (doesDirectoryExist, doesFileExist, findExecutable) import System.Environment (lookupEnv) -import System.FilePath ((), takeFileName) -import System.IO ( BufferMode(..), IOMode(..) - , withFile, hSetBuffering, hPutStr, hFlush, hClose - ) +import System.FilePath (takeFileName, ()) +import System.IO ( + BufferMode (..), + IOMode (..), + hClose, + hFlush, + hPutStr, + hSetBuffering, + withFile, + ) import System.IO.Temp (withSystemTempDirectory) import System.Process (callProcess, readProcess) @@ -25,45 +31,59 @@ import Bittide.Plot import Bittide.Simulate.Config generateReport :: + -- | Document description header String -> - -- ^ Document description header + -- | Directory containing the intermediate plot results FilePath -> - -- ^ Directory containing the intermediate plot results + -- | Node identifiers [(Integer, String)] -> - -- ^ Node identifiers + -- | The utilized simulation configuration SimConf -> - -- ^ The utilized simulation configuration IO () generateReport (("Bittide - " <>) -> header) dir ids cfg = withSystemTempDirectory "generate-report" $ \tmpDir -> do Just runref <- lookupEnv "RUNREF" -- remove the 'n' prefix from the node names - readProcess "sed" - [ "-e", "s/n\\([0-9]*\\)/\\1/g" + readProcess + "sed" + [ "-e" + , "s/n\\([0-9]*\\)/\\1/g" , topologyGv - ] [] + ] + [] >>= writeFile (tmpDir takeFileName topologyGv) -- render the topology as a tikz picture - topTikz <- readProcess "dot2tex" - [ "-f", "tikz" - , "--figonly" - , "--progoptions", "-K neato" - , "--nodeoptions", "every node/.style={" - <> intercalate "," - [ "fill" - , "text=white" - , "font=\\Large\\tt" - , "minimum size=2em" - , "inner sep=0pt" - ] - <> "}" - , "--edgeoptions", "line width=0.3em" - , tmpDir takeFileName topologyGv - ] [] + topTikz <- + readProcess + "dot2tex" + [ "-f" + , "tikz" + , "--figonly" + , "--progoptions" + , "-K neato" + , "--nodeoptions" + , "every node/.style={" + <> intercalate + "," + [ "fill" + , "text=white" + , "font=\\Large\\tt" + , "minimum size=2em" + , "inner sep=0pt" + ] + <> "}" + , "--edgeoptions" + , "line width=0.3em" + , tmpDir takeFileName topologyGv + ] + [] -- get the current date/time reference - datetime <- readProcess "date" - [ "+%Y-%m-%d %H:%M:%S" - ] [] + datetime <- + readProcess + "date" + [ "+%Y-%m-%d %H:%M:%S" + ] + [] -- create the latex report withFile (tmpDir "report.tex") WriteMode $ \h -> do hSetBuffering h NoBuffering @@ -71,29 +91,32 @@ generateReport (("Bittide - " <>) -> header) dir ids cfg = hFlush h hClose h -- create the report pdf - callProcess "lualatex" + callProcess + "lualatex" [ "--output-directory=" <> tmpDir , tmpDir "report.tex" ] -- move it to the target directory - callProcess "mv" + callProcess + "mv" [ tmpDir "report.pdf" , dir "report.pdf" ] where - clocksPdf = dir plotClocksFileName - ebsPdf = dir plotElasticBuffersFileName + clocksPdf = dir plotClocksFileName + ebsPdf = dir plotElasticBuffersFileName topologyGv = dir simTopologyFileName checkDependencies :: IO (Maybe String) checkDependencies = - either Just (const Nothing) . sequence_ <$> sequence - [ checkEVarExists "RUNREF" - , checkProgExists "mv" - , checkProgExists "sed" - , checkProgExists "dot2tex" - , checkProgExists "date" - ] + either Just (const Nothing) . sequence_ + <$> sequence + [ checkEVarExists "RUNREF" + , checkProgExists "mv" + , checkProgExists "sed" + , checkProgExists "dot2tex" + , checkProgExists "date" + ] where checkEVarExists e = maybe (Left $ "Missing environment variable: " <> e) (const $ Right ()) @@ -101,16 +124,17 @@ checkDependencies = checkProgExists p = maybe (Left $ "Missing dependency: " <> p) (const $ Right ()) - <$> findExecutable p + <$> findExecutable p checkIntermediateResults :: FilePath -> IO (Maybe String) checkIntermediateResults dir = - either Just (const Nothing) . sequence_ <$> sequence - [ checkDirExists dir - , checkFileExists $ dir plotClocksFileName - , checkFileExists $ dir plotElasticBuffersFileName - , checkFileExists $ dir simTopologyFileName - ] + either Just (const Nothing) . sequence_ + <$> sequence + [ checkDirExists dir + , checkFileExists $ dir plotClocksFileName + , checkFileExists $ dir plotElasticBuffersFileName + , checkFileExists $ dir simTopologyFileName + ] where checkDirExists d = bool (Left $ "No such directory: " <> d) (Right ()) @@ -121,147 +145,163 @@ checkIntermediateResults dir = <$> doesFileExist f toLatex :: + -- | date & time reference String -> - -- ^ date & time reference + -- | Github run reference String -> - -- ^ Github run reference + -- | Document description header String -> - -- ^ Document description header + -- | File path of the clocks plot pdf FilePath -> - -- ^ File path of the clocks plot pdf + -- | File path of the elastic buffers plot pdf FilePath -> - -- ^ File path of the elastic buffers plot pdf + -- | Tikz plot of the topology String -> - -- ^ Tikz plot of the topology + -- | Node identifiers [(Integer, String)] -> - -- ^ Node identifiers + -- | The utilized simulation configuration SimConf -> - -- ^ The utilized simulation configuration String -toLatex datetime runref header clocksPdf ebsPdf topTikz ids SimConf{..} = unlines - [ "\\documentclass[landscape]{article}" - , "" - , "\\usepackage[top=3cm,bottom=3cm,left=1.5cm,right=1.5cm]{geometry}" - , "\\usepackage[hidelinks]{hyperref}" - , "\\usepackage[dvipsnames]{xcolor}" - , "\\usepackage{graphicx}" - , "\\usepackage{pifont}" - , "\\usepackage{fancyhdr}" - , "\\usepackage{tikz}" - , "" - , "\\usetikzlibrary{shapes, calc, shadows}" - , "" - , "\\pagestyle{fancy}" - , "\\fancyhf{}" - , "\\fancyhead[L]{\\large \\textbf{" <> header <> "}}" - , "\\fancyhead[C]{\\large Topology Type: \\texttt{" - <> maybe "unknown" show mTopologyType <> "}}" - , "\\fancyhead[R]{\\large " <> datetime <> "}" - , "\\renewcommand{\\headrulewidth}{0.4pt}" - , "\\fancyfoot[L]{\\large\\textit{\\href{" - <> runref <> "}{" <> runref <> "}}}" - , "\\fancyfoot[R]{\\large\\copyright~Google Inc., QBayLogic B.V.}" - , "\\renewcommand{\\footrulewidth}{0.4pt}" - , "" - , "\\parindent0pt" - , "" - , "\\begin{document}" - , "" - , "\\ \\vspace{3em}" - , "" - , "\\begin{center}" - , "\\begin{tikzpicture}[overlay, xshift=0.27\\textwidth, yshift=-3]" - , "\\node {" - , "\\begin{tikzpicture}" - , "\\node (A) {\\resizebox{!}{10em}{" - , topTikz - , "}};" - , if null ids then "" else unlines $ - [ "\\node at ($ (A.east) + (3,0) $) {" - , "\\small\\tt" - , "\\begin{tabular}{r|c}" - , " & \\textbf{FPGA ID} \\\\[0.1em]" - , "\\hline \\\\[-0.9em]" - ] <> map (\(i,n) -> show i <> " & " <> n <> " \\\\") ids <> - [ "\\end{tabular}" - , "};" - ] - , "\\end{tikzpicture}" - , "};" - , "\\end{tikzpicture}" - , "\\end{center}" - , "" - , "\\vspace{-5em}" - , "" - , "\\begin{large}" - , " \\begin{tabular}{rl}" - , " duration \\textit{(clock cycles)}:" - , " & " <> show duration <> " \\\\" - , " stability detector - framesize:" - , " & " <> show stabilityFrameSize <> " \\\\" - , " stability detector - margin:" - , " & \\textpm\\," <> show stabilityMargin <> " elements \\\\" - , " when stable, automatically stop after \\textit{(clock cycles)}:" - , " & " <> maybe "not used" show stopAfterStable <> " \\\\" - , " clock offsets \\textit{(fs)}:" - , " & " <> intercalate ", " (show <$> clockOffsets) <> " \\\\" - , " startup delays \\textit{(clock cycles)}:" - , " & " <> intercalate ", " (show <$> startupDelays) <> " \\\\" - , " reframing:" - , " & " <> "\\textit{" - <> bool "disabled" "enabled" reframe - <> "} \\\\" - , if reframe then " wait time: & " <> show waitTime <> " \\\\" else "" - - , " all buffers stable at the end of simulation:" - , " & " <> maybe "" - ( bool "\\textcolor{red!50!black}{\\ding{55}}" - "\\textcolor{green!50!black}{\\ding{51}}" - ) stable - <> " \\\\" - , " \\end{tabular}" - , "\\end{large}" - , "" - , "\\vfill" - , "" - , "\\begin{center}" - , " \\begin{tikzpicture}" - , " \\node (clocks) at (0,0) {" - , " \\includegraphics[width=.49\\textwidth]{" <> clocksPdf <> "}" - , " };" - , " \\node (ebs) at (0.51\\textwidth, 0) {" - , " \\includegraphics[width=.49\\textwidth]{" <> ebsPdf <> "}" - , " };" - , " \\node at ($ (clocks.north) + (0,0) $) {" - , " \\textbf{Clocks}" - , " };" - , " \\node at ($ (ebs.north) + (0,0) $) {" - , " \\textbf{Elastic Buffer Occupancies}" - , " };" - , " \\node[overlay,anchor=north west,fill=blue]" - , " (A) at ($ (ebs.south west) + (1.55,0) $) {};" - , " \\node[overlay,anchor=north west,inner sep=0pt]" - , " (B) at ($ (A.north east) + (0.2,0) $) {" - , " \\small\\textit{buffer is stable}" - , " };" - , " \\node[overlay,anchor=north west,fill=OliveGreen]" - , " (C) at ($ (B.north east) + (0.6,0) $) {};" - , " \\node[overlay,anchor=north west,inner sep=0pt]" - , " (D) at ($ (C.north east) + (0.2,0) $) {" - , " \\small\\textit{buffer is stable and centered}" - , " };" - , if not reframe then "" else unlines - [ " \\node[overlay,anchor=north west,fill=red]" - , " (E) at ($ (A.south west) + (0,-0.2) $) {};" - , " \\node[overlay,anchor=north west,inner sep=0pt]" - , " (F) at ($ (E.north east) + (0.2,0) $) {" - , " \\small\\textit{waiting period (reframing)}" - , " };" - ] - , " \\end{tikzpicture}" - , "\\end{center}" - , "" - , "~" - , "" - , "\\end{document}" - ] +toLatex datetime runref header clocksPdf ebsPdf topTikz ids SimConf{..} = + unlines + [ "\\documentclass[landscape]{article}" + , "" + , "\\usepackage[top=3cm,bottom=3cm,left=1.5cm,right=1.5cm]{geometry}" + , "\\usepackage[hidelinks]{hyperref}" + , "\\usepackage[dvipsnames]{xcolor}" + , "\\usepackage{graphicx}" + , "\\usepackage{pifont}" + , "\\usepackage{fancyhdr}" + , "\\usepackage{tikz}" + , "" + , "\\usetikzlibrary{shapes, calc, shadows}" + , "" + , "\\pagestyle{fancy}" + , "\\fancyhf{}" + , "\\fancyhead[L]{\\large \\textbf{" <> header <> "}}" + , "\\fancyhead[C]{\\large Topology Type: \\texttt{" + <> maybe "unknown" show mTopologyType + <> "}}" + , "\\fancyhead[R]{\\large " <> datetime <> "}" + , "\\renewcommand{\\headrulewidth}{0.4pt}" + , "\\fancyfoot[L]{\\large\\textit{\\href{" + <> runref + <> "}{" + <> runref + <> "}}}" + , "\\fancyfoot[R]{\\large\\copyright~Google Inc., QBayLogic B.V.}" + , "\\renewcommand{\\footrulewidth}{0.4pt}" + , "" + , "\\parindent0pt" + , "" + , "\\begin{document}" + , "" + , "\\ \\vspace{3em}" + , "" + , "\\begin{center}" + , "\\begin{tikzpicture}[overlay, xshift=0.27\\textwidth, yshift=-3]" + , "\\node {" + , "\\begin{tikzpicture}" + , "\\node (A) {\\resizebox{!}{10em}{" + , topTikz + , "}};" + , if null ids + then "" + else + unlines $ + [ "\\node at ($ (A.east) + (3,0) $) {" + , "\\small\\tt" + , "\\begin{tabular}{r|c}" + , " & \\textbf{FPGA ID} \\\\[0.1em]" + , "\\hline \\\\[-0.9em]" + ] + <> map (\(i, n) -> show i <> " & " <> n <> " \\\\") ids + <> [ "\\end{tabular}" + , "};" + ] + , "\\end{tikzpicture}" + , "};" + , "\\end{tikzpicture}" + , "\\end{center}" + , "" + , "\\vspace{-5em}" + , "" + , "\\begin{large}" + , " \\begin{tabular}{rl}" + , " duration \\textit{(clock cycles)}:" + , " & " <> show duration <> " \\\\" + , " stability detector - framesize:" + , " & " <> show stabilityFrameSize <> " \\\\" + , " stability detector - margin:" + , " & \\textpm\\," <> show stabilityMargin <> " elements \\\\" + , " when stable, automatically stop after \\textit{(clock cycles)}:" + , " & " <> maybe "not used" show stopAfterStable <> " \\\\" + , " clock offsets \\textit{(fs)}:" + , " & " <> intercalate ", " (show <$> clockOffsets) <> " \\\\" + , " startup delays \\textit{(clock cycles)}:" + , " & " <> intercalate ", " (show <$> startupDelays) <> " \\\\" + , " reframing:" + , " & " + <> "\\textit{" + <> bool "disabled" "enabled" reframe + <> "} \\\\" + , if reframe then " wait time: & " <> show waitTime <> " \\\\" else "" + , " all buffers stable at the end of simulation:" + , " & " + <> maybe + "" + ( bool + "\\textcolor{red!50!black}{\\ding{55}}" + "\\textcolor{green!50!black}{\\ding{51}}" + ) + stable + <> " \\\\" + , " \\end{tabular}" + , "\\end{large}" + , "" + , "\\vfill" + , "" + , "\\begin{center}" + , " \\begin{tikzpicture}" + , " \\node (clocks) at (0,0) {" + , " \\includegraphics[width=.49\\textwidth]{" <> clocksPdf <> "}" + , " };" + , " \\node (ebs) at (0.51\\textwidth, 0) {" + , " \\includegraphics[width=.49\\textwidth]{" <> ebsPdf <> "}" + , " };" + , " \\node at ($ (clocks.north) + (0,0) $) {" + , " \\textbf{Clocks}" + , " };" + , " \\node at ($ (ebs.north) + (0,0) $) {" + , " \\textbf{Elastic Buffer Occupancies}" + , " };" + , " \\node[overlay,anchor=north west,fill=blue]" + , " (A) at ($ (ebs.south west) + (1.55,0) $) {};" + , " \\node[overlay,anchor=north west,inner sep=0pt]" + , " (B) at ($ (A.north east) + (0.2,0) $) {" + , " \\small\\textit{buffer is stable}" + , " };" + , " \\node[overlay,anchor=north west,fill=OliveGreen]" + , " (C) at ($ (B.north east) + (0.6,0) $) {};" + , " \\node[overlay,anchor=north west,inner sep=0pt]" + , " (D) at ($ (C.north east) + (0.2,0) $) {" + , " \\small\\textit{buffer is stable and centered}" + , " };" + , if not reframe + then "" + else + unlines + [ " \\node[overlay,anchor=north west,fill=red]" + , " (E) at ($ (A.south west) + (0,-0.2) $) {};" + , " \\node[overlay,anchor=north west,inner sep=0pt]" + , " (F) at ($ (E.north east) + (0.2,0) $) {" + , " \\small\\textit{waiting period (reframing)}" + , " };" + ] + , " \\end{tikzpicture}" + , "\\end{center}" + , "" + , "~" + , "" + , "\\end{document}" + ] diff --git a/bittide-experiments/src/Bittide/Simulate.hs b/bittide-experiments/src/Bittide/Simulate.hs index e3fecda22..c76e0568e 100644 --- a/bittide-experiments/src/Bittide/Simulate.hs +++ b/bittide-experiments/src/Bittide/Simulate.hs @@ -1,57 +1,57 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ImplicitPrelude #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -module Bittide.Simulate - ( OutputMode(..) - , SimPlotSettings(..) - , simPlot - , someCCC - ) where +{-# LANGUAGE ImplicitPrelude #-} -import Clash.Prelude - ( KnownDomain - , KnownNat - , SomeNat(..) - , type (<=) - , type (+) - , someNatVal - , natToNum - , snatProxy - ) +module Bittide.Simulate ( + OutputMode (..), + SimPlotSettings (..), + simPlot, + someCCC, +) where +import Clash.Prelude ( + KnownDomain, + KnownNat, + SomeNat (..), + natToNum, + snatProxy, + someNatVal, + type (+), + type (<=), + ) + +import Clash.Signal.Internal (Femtoseconds (..)) import Clash.Sized.Vector qualified as V -import Clash.Signal.Internal (Femtoseconds(..)) -import System.Exit (die) -import Text.Read (Read(..), lexP, pfail, readMaybe) -import Text.Read.Lex (Lexeme(Ident)) -import Data.Proxy (Proxy(..)) -import Data.Aeson (ToJSON, FromJSON, Value(..)) -import Data.Aeson.Types (typeMismatch) +import Control.Monad (forM_, zipWithM_) +import Data.Aeson (FromJSON, ToJSON, Value (..)) import Data.Aeson qualified as A +import Data.Aeson.Types (typeMismatch) +import Data.Array (bounds, (!)) +import Data.ByteString.Lazy qualified as BSL (appendFile) +import Data.Csv (encode, toField) +import Data.Proxy (Proxy (..)) import Data.Text qualified as T -import Data.Array ((!), bounds) -import Data.Csv (toField, encode) -import Control.Monad (zipWithM_, forM_) +import System.Exit (die) import System.FilePath (()) -import System.Random (Random(..), randomRIO) -import Data.ByteString.Lazy qualified as BSL (appendFile) +import System.Random (Random (..), randomRIO) +import Text.Read (Read (..), lexP, pfail, readMaybe) +import Text.Read.Lex (Lexeme (Ident)) -import Data.Type.Equality ((:~:)(..)) -import GHC.TypeLits.Compare ((:<=?)(..)) +import Data.Type.Equality ((:~:) (..)) +import GHC.TypeLits.Compare ((:<=?) (..)) import GHC.TypeLits.Witnesses ((%<=?)) -import GHC.TypeLits.Witnesses qualified as TLW (SNat(..)) +import GHC.TypeLits.Witnesses qualified as TLW (SNat (..)) -import Bittide.Arithmetic.Ppm (Ppm(..), diffPeriod) -import Bittide.ClockControl (ClockControlConfig(..), clockPeriodFs, defClockConfig) -import Bittide.Plot (plot, fromRfState) -import Bittide.Simulate.Topology (simulate, simulationEntity, allSettled) +import Bittide.Arithmetic.Ppm (Ppm (..), diffPeriod) +import Bittide.ClockControl (ClockControlConfig (..), clockPeriodFs, defClockConfig) +import Bittide.Plot (fromRfState, plot) +import Bittide.Simulate.Topology (allSettled, simulate, simulationEntity) import Bittide.Topology data OutputMode = CSV | PDF @@ -63,10 +63,11 @@ instance Show OutputMode where PDF -> "pdf" instance Read OutputMode where - readPrec = lexP >>= \case - Ident "csv" -> return CSV - Ident "pdf" -> return PDF - _ -> pfail + readPrec = + lexP >>= \case + Ident "csv" -> return CSV + Ident "pdf" -> return PDF + _ -> pfail instance ToJSON OutputMode where toJSON = String . T.pack . show @@ -74,56 +75,65 @@ instance ToJSON OutputMode where instance FromJSON OutputMode where parseJSON v = case v of String str -> maybe tmm return $ readMaybe $ T.unpack str - _ -> tmm + _ -> tmm where tmm = typeMismatch "OutputMode" v -data SimPlotSettings = - SimPlotSettings - { plotSamples :: Int - , periodsize :: Int - , mode :: OutputMode - , dir :: FilePath - , stopStable :: Maybe Int - , fixClockOffs :: [Float] - , fixStartDelays :: [Int] - , maxStartDelay :: Int - , sccc :: SomeClockControlConfig - , save :: [Float] -> [Int] -> Maybe Bool -> IO () - } +data SimPlotSettings = SimPlotSettings + { plotSamples :: Int + , periodsize :: Int + , mode :: OutputMode + , dir :: FilePath + , stopStable :: Maybe Int + , fixClockOffs :: [Float] + , fixStartDelays :: [Int] + , maxStartDelay :: Int + , sccc :: SomeClockControlConfig + , save :: [Float] -> [Int] -> Maybe Bool -> IO () + } --- | Creates some clock control configuration from the default with --- the given parameters modified. +{- | Creates some clock control configuration from the default with +the given parameters modified. +-} someCCC :: forall dom. - KnownDomain dom => - Proxy dom -> Bool -> Bool -> Int -> Integer -> Integer -> + (KnownDomain dom) => + Proxy dom -> + Bool -> + Bool -> + Int -> + Integer -> + Integer -> IO SomeClockControlConfig someCCC _ reframe rustySim waittime margin framesize = case someNatVal margin of Just (SomeNat pMargin) -> case somePositiveNat framesize of Just (SomePositiveNat pFramesize) -> - return $ SomeClockControlConfig @dom @12 $ ClockControlConfig - { cccStabilityCheckerMargin = snatProxy pMargin - , cccStabilityCheckerFramesize = snatProxy pFramesize - , cccEnableReframing = reframe - , cccReframingWaitTime = fromInteger $ toInteger waittime - , cccEnableRustySimulation = rustySim - , .. - } + return $ + SomeClockControlConfig @dom @12 $ + ClockControlConfig + { cccStabilityCheckerMargin = snatProxy pMargin + , cccStabilityCheckerFramesize = snatProxy pFramesize + , cccEnableReframing = reframe + , cccReframingWaitTime = fromInteger $ toInteger waittime + , cccEnableRustySimulation = rustySim + , .. + } _ -> die "ERROR: the given frame size must be positive" _ -> die "ERROR: the given margin must be non-negative" where ClockControlConfig{..} = defClockConfig @dom somePositiveNat :: Integer -> Maybe SomePositiveNat - somePositiveNat n = someNatVal n >>= \(SomeNat (_ :: p n)) -> - case TLW.SNat @1 %<=? TLW.SNat @n of - LE Refl -> Just $ SomePositiveNat (Proxy @n) - _ -> Nothing + somePositiveNat n = + someNatVal n >>= \(SomeNat (_ :: p n)) -> + case TLW.SNat @1 %<=? TLW.SNat @n of + LE Refl -> Just $ SomePositiveNat (Proxy @n) + _ -> Nothing --- | Simulates and plots the given topology according to the given --- parameters. +{- | Simulates and plots the given topology according to the given +parameters. +-} simPlot :: STop -> SimPlotSettings -> IO Bool simPlot (STop (t :: Topology n)) settings@SimPlotSettings{..} = case TLW.SNat @1 %<=? topSize t of @@ -139,45 +149,47 @@ simPlot (STop (t :: Topology n)) settings@SimPlotSettings{..} = _ -> die "ERROR: nodes + dcount <= 32" _ -> die "ERROR: elastic buffer data counts must contain data" _ -> die "ERROR: the given frame size must be positive" - _ -> die "ERROR: the given topology must have not more than 20 nodes" - _ -> die "ERROR: the given topology must have at least 1 node" + _ -> die "ERROR: the given topology must have not more than 20 nodes" + _ -> die "ERROR: the given topology must have at least 1 node" where - topSize :: KnownNat n => Topology n -> TLW.SNat n + topSize :: (KnownNat n) => Topology n -> TLW.SNat n topSize = const TLW.SNat --- | Creates and write plots for a given topology according to the --- given output mode. +{- | Creates and write plots for a given topology according to the +given output mode. +-} simPlot# :: forall dom nodes dcount margin framesize. ( KnownDomain dom - -- ^ domain - , KnownNat nodes - -- ^ the size of the topology is know - , KnownNat dcount - -- ^ the size of the data counts is known - , KnownNat margin - -- ^ the margins of the stability checker are known - , KnownNat framesize - -- ^ the frame size of cycles within the margins required is known - , 1 <= nodes - -- ^ the topology consists of at least one node - , 1 <= dcount - -- ^ data counts must contain data - , nodes + dcount <= 32 - -- ^ computational limit of the clock control - , 1 + nodes <= 32 - -- ^ computational limit of the clock control - , 1 <= framesize - -- ^ frames must at least cover one element + , -- \^ domain + KnownNat nodes + , -- \^ the size of the topology is know + KnownNat dcount + , -- \^ the size of the data counts is known + KnownNat margin + , -- \^ the margins of the stability checker are known + KnownNat framesize + , -- \^ the frame size of cycles within the margins required is known + 1 <= nodes + , -- \^ the topology consists of at least one node + 1 <= dcount + , -- \^ data counts must contain data + nodes + dcount <= 32 + , -- \^ computational limit of the clock control + 1 + nodes <= 32 + , -- \^ computational limit of the clock control + 1 <= framesize ) => + -- \^ frames must at least cover one element + + -- | simulation settings SimPlotSettings -> - -- ^ simulation settings + -- | clock control configuration ClockControlConfig dom dcount margin framesize -> - -- ^ clock control configuration + -- | the topology Topology nodes -> - -- ^ the topology + -- | stability result IO Bool - -- ^ stability result simPlot# simSettings ccc t = do clockOffsets <- V.zipWith (maybe id const) givenClockOffsets @@ -186,16 +198,19 @@ simPlot# simSettings ccc t = do V.zipWith (maybe id const) givenStartupDelays <$> genStartupOffsets maxStartDelay let - simResult = simulate t stopStable plotSamples periodsize - $ simulationEntity t ccc - (Femtoseconds . floor <$> clockOffsets) - startupDelays + simResult = + simulate t stopStable plotSamples periodsize $ + simulationEntity + t + ccc + (Femtoseconds . floor <$> clockOffsets) + startupDelays saveSettings = save (V.toList clockOffsets) (V.toList startupDelays) saveSettings Nothing case mode of - PDF -> plot dir t $ fmap (fmap (\(a,b,c,d) -> (a,b,fromRfState c,d))) simResult + PDF -> plot dir t $ fmap (fmap (\(a, b, c, d) -> (a, b, fromRfState c, d))) simResult CSV -> dumpCsv simResult let result = allSettled $ V.map last simResult @@ -215,31 +230,36 @@ simPlot# simSettings ccc t = do } = simSettings givenClockOffsets = - V.unsafeFromList - $ take (natToNum @nodes) - $ (Just <$> fixClockOffs) <> repeat Nothing + V.unsafeFromList $ + take (natToNum @nodes) $ + (Just <$> fixClockOffs) <> repeat Nothing givenStartupDelays = - V.unsafeFromList - $ take (natToNum @nodes) - $ (Just <$> fixStartDelays) <> repeat Nothing + V.unsafeFromList $ + take (natToNum @nodes) $ + (Just <$> fixStartDelays) <> repeat Nothing dumpCsv simulationResult = do - forM_ [0..n] $ \i -> do + forM_ [0 .. n] $ \i -> do let eb = topologyGraph t ! i - writeFile (filename i) - ( "t,clk" <> show i - <> concatMap (\j -> ",eb" <> show i <> show j) eb <> "\n") + writeFile + (filename i) + ( "t,clk" + <> show i + <> concatMap (\j -> ",eb" <> show i <> show j) eb + <> "\n" + ) let dats = V.map (encode . fmap flatten) simulationResult zipWithM_ (\dat i -> BSL.appendFile (filename i) dat) (V.toList dats) - [(0 :: Int)..] + [(0 :: Int) ..] filename i = dir "clocks" <> "_" <> show i <> ".csv" flatten (a, b, _, v) = toField a : toField b : (toField . fst <$> v) - (z, n) | z == 0 = bounds $ topologyGraph t - | otherwise = error "lower bound not 0" + (z, n) + | z == 0 = bounds $ topologyGraph t + | otherwise = error "lower bound not 0" -- | Generates a vector of random clock offsets. genClockOffsets :: @@ -259,16 +279,18 @@ genClockOffsets ClockControlConfig{cccDeviation} = -- | Generates a vector of random startup offsets. genStartupOffsets :: (Random a, Num a, KnownNat k) => a -> IO (V.Vec k a) genStartupOffsets limit = - V.traverse# (const ((+1) <$> randomRIO (0, limit))) $ V.repeat () + V.traverse# (const ((+ 1) <$> randomRIO (0, limit))) $ V.repeat () -data SomePositiveNat = - forall n. (KnownNat n, 1 <= n) => +data SomePositiveNat + = forall n. + (KnownNat n, 1 <= n) => SomePositiveNat (Proxy n) -data SomeClockControlConfig = - forall dom dcount margin framesize. +data SomeClockControlConfig + = forall dom dcount margin framesize. ( KnownDomain dom , KnownNat dcount , KnownNat margin , KnownNat framesize - ) => SomeClockControlConfig (ClockControlConfig dom dcount margin framesize) + ) => + SomeClockControlConfig (ClockControlConfig dom dcount margin framesize) diff --git a/bittide-experiments/src/Bittide/Simulate/Config.hs b/bittide-experiments/src/Bittide/Simulate/Config.hs index 0b552cdc9..2ccf62c5e 100644 --- a/bittide-experiments/src/Bittide/Simulate/Config.hs +++ b/bittide-experiments/src/Bittide/Simulate/Config.hs @@ -1,23 +1,23 @@ +{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE ImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -module Bittide.Simulate.Config - ( SimConf(..) - , simJsonConfigFileName - , simTopologyFileName - , simConfigCLIParser - , saveSimConfig - ) where -import Bittide.Simulate (OutputMode(..)) -import Bittide.Topology (TopologyType(..), STop(..), toDot, topTypeCLIParser) +module Bittide.Simulate.Config ( + SimConf (..), + simJsonConfigFileName, + simTopologyFileName, + simConfigCLIParser, + saveSimConfig, +) where -import Data.Aeson (ToJSON(..), FromJSON(..), encode) +import Bittide.Simulate (OutputMode (..)) +import Bittide.Topology (STop (..), TopologyType (..), toDot, topTypeCLIParser) + +import Data.Aeson (FromJSON (..), ToJSON (..), encode) import Data.ByteString.Lazy qualified as BS (writeFile) -import Data.Default (Default(..)) +import Data.Default (Default (..)) import GHC.Generics (Generic) import Language.Dot.Pretty (render) import System.Directory (createDirectoryIfMissing) @@ -34,243 +34,264 @@ simTopologyFileName :: String simTopologyFileName = "topology.gv" -- | Collection of all simulation configuration parameters. -data SimConf = - SimConf - { mTopologyType :: Maybe (TopologyType IO Integer) - -- ^ The topology type of the network to be simulated. Have a - -- look at 'Bittide.Topology' for more insights on the supported - -- topology types and their corresponding topologies. - , outMode :: OutputMode - -- ^ Some selector of how the data of the simulation result is - -- returned for furhter processing. - , duration :: Int - -- ^ The number of clock cycles to simulate. - , samples :: Int - -- ^ The number of samples to be utilized for result - -- generation. From the 'duration' many samples available, only - -- every @duration `quot` samples@th sample is used. - , stabilityMargin :: Int - -- ^ Maximum number of elements a buffer occupancy is allowed to - -- deviate to be considered stable. - -- (cf. 'Bittide.ClockControl.StabilityChecker') - , stabilityFrameSize :: Int - -- ^ The minimum number of clock cycles a buffer occupancy must - -- remain within to be considered stable. - -- (cf. 'Bittide.ClockControl.StabilityChecker') - , reframe :: Bool - -- ^ Some flag for enabeling or disabling reframing. - , rusty :: Bool - -- ^ Some flag for enabeling or disabling the simulation of - -- clock control via the Rust FFI. - , waitTime :: Int - -- ^ Number of clock cycles to wait until reframing takes place - -- (after stability has been detected, for all elastic buffers). - , stopWhenStable :: Bool - -- ^ Stop simulation as soon as all buffers get stable. - , stopAfterStable :: Maybe Int - -- ^ Stop simulation after all buffers have been stable for - -- at least the given number of clock cycles. - , clockOffsets :: [Float] - -- ^ The initital clock offsets in Femtoseconds - -- (randomly generated if missing). - , startupDelays :: [Int] - -- ^ The Initital startup offsets, i.e, the number of clock - -- cycles to wait before a node gets started (according to the - -- node's individual clock, randomly generated if missing). - , maxStartupDelay :: Int - -- ^ Maximal number of clock cycles the startup of a node may be - -- delayed (bounds the randomly generated offsets)". - , createReport :: Bool - -- ^ Some flag for enabling or disabling report generation. - , outDir :: FilePath - -- ^ The directory, in which the generated files are stored. - , jsonArgs :: Maybe FilePath - -- ^ Read arguments from a 'simulate.json' file, if given. - , stable :: Maybe Bool - -- ^ Stability result of the elastic buffers at the end of - -- simulation, if available. - } +data SimConf = SimConf + { mTopologyType :: Maybe (TopologyType IO Integer) + -- ^ The topology type of the network to be simulated. Have a + -- look at 'Bittide.Topology' for more insights on the supported + -- topology types and their corresponding topologies. + , outMode :: OutputMode + -- ^ Some selector of how the data of the simulation result is + -- returned for furhter processing. + , duration :: Int + -- ^ The number of clock cycles to simulate. + , samples :: Int + -- ^ The number of samples to be utilized for result + -- generation. From the 'duration' many samples available, only + -- every @duration `quot` samples@th sample is used. + , stabilityMargin :: Int + -- ^ Maximum number of elements a buffer occupancy is allowed to + -- deviate to be considered stable. + -- (cf. 'Bittide.ClockControl.StabilityChecker') + , stabilityFrameSize :: Int + -- ^ The minimum number of clock cycles a buffer occupancy must + -- remain within to be considered stable. + -- (cf. 'Bittide.ClockControl.StabilityChecker') + , reframe :: Bool + -- ^ Some flag for enabeling or disabling reframing. + , rusty :: Bool + -- ^ Some flag for enabeling or disabling the simulation of + -- clock control via the Rust FFI. + , waitTime :: Int + -- ^ Number of clock cycles to wait until reframing takes place + -- (after stability has been detected, for all elastic buffers). + , stopWhenStable :: Bool + -- ^ Stop simulation as soon as all buffers get stable. + , stopAfterStable :: Maybe Int + -- ^ Stop simulation after all buffers have been stable for + -- at least the given number of clock cycles. + , clockOffsets :: [Float] + -- ^ The initital clock offsets in Femtoseconds + -- (randomly generated if missing). + , startupDelays :: [Int] + -- ^ The Initital startup offsets, i.e, the number of clock + -- cycles to wait before a node gets started (according to the + -- node's individual clock, randomly generated if missing). + , maxStartupDelay :: Int + -- ^ Maximal number of clock cycles the startup of a node may be + -- delayed (bounds the randomly generated offsets)". + , createReport :: Bool + -- ^ Some flag for enabling or disabling report generation. + , outDir :: FilePath + -- ^ The directory, in which the generated files are stored. + , jsonArgs :: Maybe FilePath + -- ^ Read arguments from a 'simulate.json' file, if given. + , stable :: Maybe Bool + -- ^ Stability result of the elastic buffers at the end of + -- simulation, if available. + } deriving (Show, Ord, Eq, Generic, ToJSON, FromJSON) instance Default SimConf where - def = SimConf - { mTopologyType = Nothing - , outMode = PDF - , duration = 150000 - , samples = 100 - , stabilityMargin = 8 - , stabilityFrameSize = 1500000 - , reframe = True - , rusty = False - , waitTime = 100000 - , stopWhenStable = False - , stopAfterStable = Nothing - , clockOffsets = [] - , startupDelays = [] - , maxStartupDelay = 0 - , createReport = False - , outDir = "_build" - , jsonArgs = Nothing - , stable = Nothing - } + def = + SimConf + { mTopologyType = Nothing + , outMode = PDF + , duration = 150000 + , samples = 100 + , stabilityMargin = 8 + , stabilityFrameSize = 1500000 + , reframe = True + , rusty = False + , waitTime = 100000 + , stopWhenStable = False + , stopAfterStable = Nothing + , clockOffsets = [] + , startupDelays = [] + , maxStartupDelay = 0 + , createReport = False + , outDir = "_build" + , jsonArgs = Nothing + , stable = Nothing + } -- | Command line parser for reading a simulation configuration. simConfigCLIParser :: Parser SimConf simConfigCLIParser = SimConf <$> optional topTypeCLIParser - <*> option auto - ( long "output-mode" + <*> option + auto + ( long "output-mode" <> short 'm' <> metavar "MODE" <> value (outMode def) <> showDefault <> help "Available modes are: csv, pdf" - ) - <*> option auto - ( long "steps" + ) + <*> option + auto + ( long "steps" <> short 's' <> metavar "NUM" <> value (duration def) <> showDefault <> help "Number of clock cycles to simulate" - ) - <*> option auto - ( long "samples" + ) + <*> option + auto + ( long "samples" <> short 'a' <> metavar "NUM" <> value (samples def) <> showDefault <> help "Number of samples to keep & pass to matplotlib" - ) - <*> option auto - ( long "margin" + ) + <*> option + auto + ( long "margin" <> short 'g' <> metavar "NUM" <> value (stabilityMargin def) <> showDefault <> help - ( "Maximum number of elements a buffer occupancy is " - <> "allowed to deviate to be considered stable" - ) - ) - <*> option auto - ( long "frame-size" + ( "Maximum number of elements a buffer occupancy is " + <> "allowed to deviate to be considered stable" + ) + ) + <*> option + auto + ( long "frame-size" <> short 'f' <> metavar "NUM" <> value (stabilityFrameSize def) <> showDefault <> help - ( "Minimum number of clock cycles a buffer occupancy " - <> "must remain within to be considered stable" - ) - ) - <*> flag (reframe def) False - ( long "disable-reframing" + ( "Minimum number of clock cycles a buffer occupancy " + <> "must remain within to be considered stable" + ) + ) + <*> flag + (reframe def) + False + ( long "disable-reframing" <> short 'e' <> help "Disables clock control reframing" - ) - <*> flag (rusty def) (not $ rusty def) - ( long "get-rusty" + ) + <*> flag + (rusty def) + (not $ rusty def) + ( long "get-rusty" <> short 'y' <> help "Simulate clock control via the Rust FFI" - ) - <*> option auto - ( long "wait-time" + ) + <*> option + auto + ( long "wait-time" <> short 'w' <> metavar "NUM" <> value (waitTime def) <> showDefault <> help - ( "Number of clock cycles to wait until reframing takes place " - <> "(after stability has been detected, for all elastic buffers)" - ) - ) - <*> flag (stopWhenStable def) (not $ stopWhenStable def) - ( long "stop-when-stable" + ( "Number of clock cycles to wait until reframing takes place " + <> "(after stability has been detected, for all elastic buffers)" + ) + ) + <*> flag + (stopWhenStable def) + (not $ stopWhenStable def) + ( long "stop-when-stable" <> short 'x' <> help "Stop simulation as soon as all buffers get stable" - ) + ) <*> optional - ( option auto - ( long "stop-after-stable" + ( option + auto + ( long "stop-after-stable" <> short 'X' <> metavar "NUM" <> help - ( "Stop simulation after all buffers have been stable for " - <> " at least the given number of simulation steps" - ) - ) + ( "Stop simulation after all buffers have been stable for " + <> " at least the given number of simulation steps" + ) ) - <*> option auto - ( long "clock-offsets" + ) + <*> option + auto + ( long "clock-offsets" <> short 't' <> metavar "NUM LIST" <> value (clockOffsets def) <> showDefault <> help "Initital clock offsets (randomly generated if missing)" - ) - <*> option auto - ( long "startup-delays" + ) + <*> option + auto + ( long "startup-delays" <> short 'T' <> metavar "NUM LIST" <> value (startupDelays def) <> showDefault - <> help ( "Initital startup offsets, i.e, the number of clock cycles " - <> "to wait before a node gets started (according to the " - <> "node's individual clock, randomly generated if missing)" - ) - - ) - <*> option auto - ( long "max-startup-delay" + <> help + ( "Initital startup offsets, i.e, the number of clock cycles " + <> "to wait before a node gets started (according to the " + <> "node's individual clock, randomly generated if missing)" + ) + ) + <*> option + auto + ( long "max-startup-delay" <> short 'u' <> metavar "NUM" <> value (maxStartupDelay def) <> showDefault <> help - ( "Maximal number of clock cycles the startup of a node may be " - <> "delayed (bounds the randomly generated offsets)" - ) - ) - <*> flag (createReport def) (not $ createReport def) - ( long "create-report" + ( "Maximal number of clock cycles the startup of a node may be " + <> "delayed (bounds the randomly generated offsets)" + ) + ) + <*> flag + (createReport def) + (not $ createReport def) + ( long "create-report" <> short 'r' <> help "Create a simulation report" - ) + ) <*> strOption - ( long "output-directory" + ( long "output-directory" <> short 'o' <> metavar "DIR" <> action "directory" <> value (outDir def) <> showDefault <> help "Directory, in which the generated files are stored" - ) + ) <*> optional - ( strOption - ( long "json-args" + ( strOption + ( long "json-args" <> short 'j' <> metavar "FILE" <> action "file" <> help - ( "Read arguments from a 'simulate.json' file " - <> "(overwrites all arguments other than '-jz')" - ) - ) + ( "Read arguments from a 'simulate.json' file " + <> "(overwrites all arguments other than '-jz')" + ) ) + ) <*> pure Nothing --- | Saves a topology and a corresponding simulation configuration to --- respective files in 'outDir'. +{- | Saves a topology and a corresponding simulation configuration to +respective files in 'outDir'. +-} saveSimConfig :: STop -> SimConf -> IO () saveSimConfig (STop t) cfg@SimConf{..} = do createDirectoryIfMissing True outDir let topologyFile = outDir simTopologyFileName writeFile topologyFile $ (<> "\n") $ render $ toDot t - BS.writeFile (outDir simJsonConfigFileName) $ encode cfg - { jsonArgs = Nothing - , mTopologyType = case mTopologyType of - Just (Random{}) -> Just $ DotFile topologyFile - _ -> mTopologyType - } + BS.writeFile (outDir simJsonConfigFileName) $ + encode + cfg + { jsonArgs = Nothing + , mTopologyType = case mTopologyType of + Just (Random{}) -> Just $ DotFile topologyFile + _ -> mTopologyType + } diff --git a/bittide-experiments/src/Bittide/Simulate/ElasticBuffer.hs b/bittide-experiments/src/Bittide/Simulate/ElasticBuffer.hs index bac571f06..2f627954c 100644 --- a/bittide-experiments/src/Bittide/Simulate/ElasticBuffer.hs +++ b/bittide-experiments/src/Bittide/Simulate/ElasticBuffer.hs @@ -7,16 +7,19 @@ module Bittide.Simulate.ElasticBuffer where import Clash.Prelude import GHC.Stack -import Bittide.Counter import Bittide.ClockControl +import Bittide.Counter --- | Simple model of a FIFO that only models the interesting part for conversion: --- data counts. +{- | Simple model of a FIFO that only models the interesting part for conversion: +data counts. +-} elasticBuffer :: forall n readDom writeDom. (HasCallStack, KnownDomain readDom, KnownDomain writeDom, KnownNat n) => Clock readDom -> Clock writeDom -> Signal readDom (RelDataCount n) -elasticBuffer clkRead clkWrite = resize . fst - <$> domainDiffCounter clkWrite resetGen clkRead resetGen +elasticBuffer clkRead clkWrite = + resize + . fst + <$> domainDiffCounter clkWrite resetGen clkRead resetGen diff --git a/bittide-experiments/src/Bittide/Simulate/Time.hs b/bittide-experiments/src/Bittide/Simulate/Time.hs index 6b94833c2..94d2f7690 100644 --- a/bittide-experiments/src/Bittide/Simulate/Time.hs +++ b/bittide-experiments/src/Bittide/Simulate/Time.hs @@ -2,13 +2,13 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Bittide.Simulate.Time - ( Offset - , StepSize - , Period - , addFs - , subFsZero - ) where +module Bittide.Simulate.Time ( + Offset, + StepSize, + Period, + addFs, + subFsZero, +) where import Clash.Prelude import Clash.Signal.Internal diff --git a/bittide-experiments/src/Bittide/Simulate/Topology.hs b/bittide-experiments/src/Bittide/Simulate/Topology.hs index e12880c77..c730f2349 100644 --- a/bittide-experiments/src/Bittide/Simulate/Topology.hs +++ b/bittide-experiments/src/Bittide/Simulate/Topology.hs @@ -1,31 +1,31 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} --- | This module defines the top entity for simulation, where every --- non-empty topology is supported. The top entity can be simulated --- using 'simulate'. -module Bittide.Simulate.Topology - ( simulationEntity - , simulate - , allSettled - , takeEveryN - ) +{- | This module defines the top entity for simulation, where every + non-empty topology is supported. The top entity can be simulated + using 'simulate'. +-} +module Bittide.Simulate.Topology ( + simulationEntity, + simulate, + allSettled, + takeEveryN, +) where import Clash.Prelude hiding (simulate) -import Clash.Signal.Internal - ( Signal(..) - , Clock(..) - , Femtoseconds(..) - ) +import Clash.Signal.Internal ( + Clock (..), + Femtoseconds (..), + Signal (..), + ) +import Data.List qualified as L (drop, repeat, replicate, take) import Data.Maybe -import Data.Proxy (Proxy(..)) -import Data.List qualified as L (take, drop, repeat, replicate) +import Data.Proxy (Proxy (..)) import Bittide.ClockControl import Bittide.ClockControl.Callisto hiding (allSettled) @@ -36,66 +36,72 @@ import Bittide.Simulate.Time import Bittide.Simulate.TunableClockGen import Bittide.Topology --- | The entity to be simulated consisting of the tunable clock --- generators, the elastic buffers, the stability checkers, and the --- clock controls, wired according to the given topology. --- --- NOTE: All clocks are implicitly synchronized to the same clock --- domain at this point, which is ok as long as the dynamic clock --- generator is used. Otherwise the domains have to be differentiated --- at the type level, which is not straightforward to archive for --- fully connected topologies. +{- | The entity to be simulated consisting of the tunable clock +generators, the elastic buffers, the stability checkers, and the +clock controls, wired according to the given topology. + +NOTE: All clocks are implicitly synchronized to the same clock +domain at this point, which is ok as long as the dynamic clock +generator is used. Otherwise the domains have to be differentiated +at the type level, which is not straightforward to archive for +fully connected topologies. +-} simulationEntity :: forall dom nodes dcount margin framesize. ( KnownDomain dom - -- ^ domain - , KnownNat nodes - -- ^ the size of the topology is known - , KnownNat dcount - -- ^ the size of the data counts is known - , KnownNat margin - -- ^ the margins of the stability checker are known - , KnownNat framesize - -- ^ the frame size of cycles within the margins required is known - , 1 <= nodes - -- ^ the topology consists of at least one node - , 1 <= dcount - -- ^ data counts must contain data - , nodes + dcount <= 32 - -- ^ computational limit of the clock control - , 1 + nodes <= 32 - -- ^ computational limit of the clock control - , 1 <= framesize - -- ^ frames must at least cover one element + , -- \^ domain + KnownNat nodes + , -- \^ the size of the topology is known + KnownNat dcount + , -- \^ the size of the data counts is known + KnownNat margin + , -- \^ the margins of the stability checker are known + KnownNat framesize + , -- \^ the frame size of cycles within the margins required is known + 1 <= nodes + , -- \^ the topology consists of at least one node + 1 <= dcount + , -- \^ data counts must contain data + nodes + dcount <= 32 + , -- \^ computational limit of the clock control + 1 + nodes <= 32 + , -- \^ computational limit of the clock control + 1 <= framesize ) => + -- \^ frames must at least cover one element + + -- | the topology Topology nodes -> - -- ^ the topology + -- | clock control configuration ClockControlConfig dom dcount margin framesize -> - -- ^ clock control configuration + -- | initial clock offsets Vec nodes Offset -> - -- ^ initial clock offsets + -- | initial startup offsets Vec nodes Int -> - -- ^ initial startup offsets - Signal dom - ( Vec nodes + -- | simulation entity + Signal + dom + ( Vec + nodes ( Period , ReframingState - , Vec nodes + , Vec + nodes ( RelDataCount dcount , StabilityIndication ) ) ) - -- ^ simulation entity simulationEntity topology ccc !clockOffsets !startupOffsets = bundle - $ zipWith3 (\x y z -> bundle (x, y, z)) + $ zipWith3 + (\x y z -> bundle (x, y, z)) clkSignals (fmap reframingState <$> callistoResults) - $ zipWith - (liftA2 zip) - (bundle <$> ebs) - (fmap stability <$> callistoResults) + $ zipWith + (liftA2 zip) + (bundle <$> ebs) + (fmap stability <$> callistoResults) where -- node specific resets according to the startup offsets rsts :: Vec nodes (Reset dom) @@ -107,10 +113,14 @@ simulationEntity topology ccc !clockOffsets !startupOffsets = ebv x = flip imap clocks . eb x eb x xClk y yClk | hasEdge topology x y = elasticBuffer xClk yClk - | otherwise = pure 0 + | otherwise = pure 0 -- clock generators - !clocks = clock <$> clockOffsets <*> rsts <*> (fmap (fromMaybe NoChange . maybeSpeedChange) <$> callistoResults) + !clocks = + clock + <$> clockOffsets + <*> rsts + <*> (fmap (fromMaybe NoChange . maybeSpeedChange) <$> callistoResults) clock offset rst = tunableClockGen (cccSettlePeriod ccc) @@ -121,14 +131,14 @@ simulationEntity topology ccc !clockOffsets !startupOffsets = -- clock controls callistoResults :: Vec nodes (Signal dom (CallistoResult nodes)) !callistoResults = - clockControl <$> clocks <*> rsts <*> masks <*> ebs + clockControl <$> clocks <*> rsts <*> masks <*> ebs clockControl clk rst = callistoClockControl clk rst enableGen ccc - . pure + . pure -- clock signals clkSignals :: Vec nodes (Signal dom Period) @@ -142,38 +152,44 @@ simulationEntity topology ccc !clockOffsets !startupOffsets = -- value level version of 'Clash.Signal.Internal.resetGenN' without -- a the need for a blackbox - resetGenN' n = unsafeFromActiveHigh $ - fromList (L.replicate n True <> L.repeat False) + resetGenN' n = + unsafeFromActiveHigh + $ fromList (L.replicate n True <> L.repeat False) -- | Simulates some topology simulation entity. simulate :: ( KnownDomain dom - -- ^ domain - , KnownNat nodes - -- ^ the size of the topology is known - , KnownNat dcount - -- ^ the size of the data counts is known + , -- \^ domain + KnownNat nodes + , -- \^ the size of the topology is known + KnownNat dcount ) => + -- \^ the size of the data counts is known + + -- | the topology Topology nodes -> - -- ^ the topology + -- | stop simulation after all buffers have been stable for @n@ steps Maybe Int -> - -- ^ stop simulation after all buffers have been stable for @n@ steps + -- | number of samples to keep & pass Int -> - -- ^ number of samples to keep & pass + -- | number of cycles in one sample period Int -> - -- ^ number of cycles in one sample period - Signal dom - ( Vec nodes + -- | simulation entity + Signal + dom + ( Vec + nodes ( Period , ReframingState - , Vec nodes + , Vec + nodes ( RelDataCount dcount , StabilityIndication ) ) ) -> - -- ^ simulation entity - Vec nodes + Vec + nodes [ ( Period , Period , ReframingState @@ -184,72 +200,76 @@ simulate :: ) ] simulate topology stopStable samples periodsize = - transposeLV - . takeWhileDelay stopStable (-1) - . L.take samples - . takeEveryN periodsize - . absTimes topology + transposeLV + . takeWhileDelay stopStable (-1) + . L.take samples + . takeEveryN periodsize + . absTimes topology where takeWhileDelay = \case Nothing -> const id - Just n -> \m -> \case - [] -> [] + Just n -> \m -> \case + [] -> [] x : xr -> - let m' | not (allSettled x) = -1 - | m < 0 = n - | m > 0 = m - 1 - | otherwise = 0 - in x : if m' == 0 then [] else takeWhileDelay (Just n) m' xr + let m' + | not (allSettled x) = -1 + | m < 0 = n + | m > 0 = m - 1 + | otherwise = 0 + in x : if m' == 0 then [] else takeWhileDelay (Just n) m' xr -- | Checks whether all stability checkers report a stable result. -allSettled :: KnownNat n => Vec n (a, b, c, [(d, StabilityIndication)]) -> Bool -allSettled = and . toList . map ((\(_,_,_,xs) -> all (settled . snd) xs)) +allSettled :: (KnownNat n) => Vec n (a, b, c, [(d, StabilityIndication)]) -> Bool +allSettled = and . toList . map ((\(_, _, _, xs) -> all (settled . snd) xs)) --- | Absolute time unfolding of the produced signal for generating the --- simulation data. +{- | Absolute time unfolding of the produced signal for generating the +simulation data. +-} absTimes :: (KnownNat nodes, NFDataX a, NFDataX b) => + -- | the topology Topology nodes -> - -- ^ the topology + -- | The signal holding the the simulation result Signal dom (Vec nodes (Period, b, Vec nodes a)) -> - -- ^ The signal holding the the simulation result - [Vec nodes (Period, Period, b, [a])] - -- ^ The same data as in the input signal, only lazily unfolded as + -- | The same data as in the input signal, only lazily unfolded as -- an infinite data stream and with the unavailable links -- already thrown out from the last tuple member. + [Vec nodes (Period, Period, b, [a])] absTimes topology = go $ replicate SNat (Femtoseconds 0) where go !ts (v :- vs) = forceX (izipWith (\i t (p, s, es) -> (t, p, s, filterAvailable i es)) ts v) - : go (forceX $ zipWith addFs ts $ map (\(x,_,_) -> x) v) vs + : go (forceX $ zipWith addFs ts $ map (\(x, _, _) -> x) v) vs -- turns a fixed sized vector of data corresponding to the topology -- links to a list of data entries, reduced to the available links filterAvailable i = catMaybes . toList . imap (asMaybe . hasEdge topology i) asMaybe = \case - True -> Just + True -> Just False -> const Nothing -- | 'L.transpose' for (possibly infinite) lists of vectors -transposeLV :: KnownNat n => [Vec n a] -> Vec n [a] +transposeLV :: (KnownNat n) => [Vec n a] -> Vec n [a] transposeLV = \case - [] -> replicate SNat [] - x:xs -> (:) <$> x <*> transposeLV xs + [] -> replicate SNat [] + x : xs -> (:) <$> x <*> transposeLV xs -- | Extracts the time periods from a clock extractPeriods :: - forall dom. KnownDomain dom => + forall dom. + (KnownDomain dom) => Clock dom -> Signal dom Period extractPeriods = \case (Clock _ (Just s)) -> s - _ -> pure (clockPeriodFs @dom Proxy) + _ -> pure (clockPeriodFs @dom Proxy) --- | As an example: --- --- >>> takeEveryN 3 [1..10] --- [1,4,7,10] +{- | As an example: + +>>> takeEveryN 3 [1..10] +[1,4,7,10] +-} takeEveryN :: Int -> [a] -> [a] takeEveryN n = \case - [] -> [] - (x:xs) -> x : takeEveryN n (L.drop (n - 1) xs) + [] -> [] + (x : xs) -> x : takeEveryN n (L.drop (n - 1) xs) diff --git a/bittide-experiments/src/Bittide/Simulate/TunableClockGen.hs b/bittide-experiments/src/Bittide/Simulate/TunableClockGen.hs index f1ba4f623..9cdb32116 100644 --- a/bittide-experiments/src/Bittide/Simulate/TunableClockGen.hs +++ b/bittide-experiments/src/Bittide/Simulate/TunableClockGen.hs @@ -1,12 +1,11 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} -module Bittide.Simulate.TunableClockGen - ( tunableClockGen - ) where +module Bittide.Simulate.TunableClockGen ( + tunableClockGen, +) where import Clash.Prelude import Clash.Signal.Internal @@ -42,7 +41,6 @@ tunableClockGen :: -- -- TODO: For the actual boards this needs to be modelled as a pulse. This pulse -- should be asserted for at least 100 ns and at a maximum rate of 1 MHz. - -- Signal dom SpeedChange -> -- | Clock with a dynamic frequency. At the time of writing, Clash primitives -- don't account for this yet, so be careful when using them. Note that dynamic @@ -53,7 +51,7 @@ tunableClockGen settlePeriod periodOffset stepSize _reset speedChange = period = clockPeriodFs @dom Proxy initPeriod = period `addFs` periodOffset clockSignal = initPeriod :- go settlePeriod initPeriod speedChange - in + in Clock SSymbol (Just clockSignal) where go :: @@ -64,9 +62,15 @@ tunableClockGen settlePeriod periodOffset stepSize _reset speedChange = go !settleCounter !period (sc :- scs) = let vars = - "settlePeriod: " <> show settlePeriod <> ", " - <> "settleCounter: " <> show settleCounter <> ", " - <> "period: " <> show period <> ", " + "settlePeriod: " + <> show settlePeriod + <> ", " + <> "settleCounter: " + <> show settleCounter + <> ", " + <> "period: " + <> show period + <> ", " (newSettleCounter, newPeriod) = case sc of SpeedUp @@ -77,5 +81,5 @@ tunableClockGen settlePeriod periodOffset stepSize _reset speedChange = | otherwise -> error $ "tunableClockGen: frequency change requested too often. " <> vars NoChange -> (settleCounter `addFs` period, period) - in + in newPeriod :- go newSettleCounter newPeriod scs diff --git a/bittide-experiments/src/Bittide/Topology.hs b/bittide-experiments/src/Bittide/Topology.hs index 5092e054c..48306601f 100644 --- a/bittide-experiments/src/Bittide/Topology.hs +++ b/bittide-experiments/src/Bittide/Topology.hs @@ -1,89 +1,117 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -module Bittide.Topology - ( -- * Data Types - TopologyType(..) - , TopologyName - , Topology - ( topologyName - , topologyGraph - , topologyType - , hasEdge - ) - , STop(..) - , TreeSize - -- * Special Topologies - , cyclic - , complete - , diamond - , grid - , star - , torus2d - , torus3d - , tree - , pendulum - , line - , hypercube - , dumbbell - , hourglass - , beads - -- * Utilities - , fromGraph - , fromTopologyType - , fromDot - , toDot - , randomTopology - , topTypeCLIParser - ) where + +module Bittide.Topology ( + -- * Data Types + TopologyType (..), + TopologyName, + Topology ( + topologyName, + topologyGraph, + topologyType, + hasEdge + ), + STop (..), + TreeSize, + + -- * Special Topologies + cyclic, + complete, + diamond, + grid, + star, + torus2d, + torus3d, + tree, + pendulum, + line, + hypercube, + dumbbell, + hourglass, + beads, + + -- * Utilities + fromGraph, + fromTopologyType, + fromDot, + toDot, + randomTopology, + topTypeCLIParser, +) where import Prelude -import Clash.Prelude - ( SNat(..) , SomeNat(..), Nat , Index, KnownNat - , type (^), type (*), type (+), type (-), type Div - , d0, d1, natToInteger, snatProxy, snatToNum, snatToInteger, someNatVal - ) +import Clash.Prelude ( + Index, + KnownNat, + Nat, + SNat (..), + SomeNat (..), + d0, + d1, + natToInteger, + snatProxy, + snatToInteger, + snatToNum, + someNatVal, + type Div, + type (*), + type (+), + type (-), + type (^), + ) -import Control.Monad (forM, forM_, when, unless, replicateM, replicateM_) -import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.=), (.:), object) +import Control.Monad (forM, forM_, replicateM, replicateM_, unless, when) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.:), (.=)) import Data.Aeson.Types (typeMismatch) import Data.Array.IO (IOUArray) -import Data.Array.MArray (newListArray, readArray, writeArray, getElems, freeze) +import Data.Array.MArray (freeze, getElems, newListArray, readArray, writeArray) import Data.Bifunctor (bimap, first) import Data.Bits (Bits (..)) import Data.Containers.ListUtils (nubOrd) import Data.Function (on) -import Data.Graph (Graph, graphFromEdges, edges, buildG, scc) +import Data.Graph (Graph, buildG, edges, graphFromEdges, scc) import Data.List (groupBy, sort) import Data.Maybe (catMaybes, mapMaybe) -import Data.Proxy (Proxy(..)) +import Data.Proxy (Proxy (..)) import Data.Tuple (swap) -import Data.Array qualified as A ((!), array, listArray, accumArray) -import Data.Map.Strict qualified as M ((!), fromList) -import Data.Set qualified as S (fromList, toList) +import Data.Array qualified as A (accumArray, array, listArray, (!)) +import Data.Map.Strict qualified as M (fromList, (!)) +import Data.Set qualified as S (fromList, toList) import GHC.Num.Natural (Natural) +import GHC.TypeLits.KnownNat (KnownNat2 (..), SNatKn (..), nameToSymbol) import GHC.TypeNats (natVal) -import GHC.TypeLits.KnownNat (KnownNat2(..), SNatKn(..), nameToSymbol) -import Language.Dot.Graph (GraphType(..), Name(..), Statement(..), Subgraph(..)) +import Language.Dot.Graph (GraphType (..), Name (..), Statement (..), Subgraph (..)) import Language.Dot.Parser (parse) -import Options.Applicative - ( Parser, action, auto, short, long, help, info, option, command - , progDesc, strOption, metavar, hsubparser, commandGroup, footerDoc - ) +import Options.Applicative ( + Parser, + action, + auto, + command, + commandGroup, + footerDoc, + help, + hsubparser, + info, + long, + metavar, + option, + progDesc, + short, + strOption, + ) import Options.Applicative.Help.Pretty (pretty) import System.Random (randomIO, randomRIO) @@ -91,36 +119,39 @@ import System.Random (randomIO, randomRIO) -- | Special topologies may have names given as a string. type TopologyName = String --- | A topology is just a simple graph extended with a type level size --- bound, a name and a 'TopologyType'. -data Topology (n :: Nat) = - Topology - { topologyName :: TopologyName - , topologyGraph :: Graph - , topologyType :: TopologyType IO Integer - , hasEdge :: Index n -> Index n -> Bool - } +{- | A topology is just a simple graph extended with a type level size +bound, a name and a 'TopologyType'. +-} +data Topology (n :: Nat) = Topology + { topologyName :: TopologyName + , topologyGraph :: Graph + , topologyType :: TopologyType IO Integer + , hasEdge :: Index n -> Index n -> Bool + } -- | Existentially quantified version hiding the type level bound. -data STop = forall n. KnownNat n => STop (Topology n) +data STop = forall n. (KnownNat n) => STop (Topology n) -- | Smart constructor of 'Topology'. -fromGraph :: forall n. KnownNat n => TopologyName -> Graph -> Topology n +fromGraph :: forall n. (KnownNat n) => TopologyName -> Graph -> Topology n fromGraph name graph = - Topology name graph (Random $ natToInteger @n) $ curry $ (A.!) - $ A.accumArray (const id) False bounds - $ zip (filter (uncurry (/=)) edgeIndices) [True, True ..] + Topology name graph (Random $ natToInteger @n) $ + curry $ + (A.!) $ + A.accumArray (const id) False bounds $ + zip (filter (uncurry (/=)) edgeIndices) [True, True ..] where bounds = ((minBound, minBound), (maxBound, maxBound)) edgeIndices = map (bimap fromIntegral fromIntegral) $ edges graph --- | Disambiguates between a selection of known topologies, topologies --- that are loaded from DOT files, and random topologies. The first --- type parameter @m@ indicates a context, that may be required to --- generate an instance of the given topology type. If no specific --- context is required @m@ is left unspecified. The second type --- parameter @n@ indicates an integral type, in which the topology may --- be parameterized. +{- | Disambiguates between a selection of known topologies, topologies +that are loaded from DOT files, and random topologies. The first +type parameter @m@ indicates a context, that may be required to +generate an instance of the given topology type. If no specific +context is required @m@ is left unspecified. The second type +parameter @n@ indicates an integral type, in which the topology may +be parameterized. +-} data TopologyType m n where Diamond :: TopologyType m n Pendulum :: n -> n -> TopologyType m n @@ -141,144 +172,146 @@ data TopologyType m n where instance Show (TopologyType m a) where show = \case - Diamond{} -> topologyName diamond - Pendulum{} -> topologyName $ pendulum d0 d0 - Line{} -> topologyName $ line d0 + Diamond{} -> topologyName diamond + Pendulum{} -> topologyName $ pendulum d0 d0 + Line{} -> topologyName $ line d0 HyperCube{} -> topologyName $ hypercube d0 - Grid{} -> topologyName $ grid d0 d0 - Torus2D{} -> topologyName $ torus2d d0 d0 - Torus3D{} -> topologyName $ torus3d d0 d0 d0 - Tree{} -> topologyName $ tree d0 d0 - Star{} -> topologyName $ star d0 - Cycle{} -> topologyName $ cyclic d0 - Complete{} -> topologyName $ complete d0 - Dumbbell{} -> topologyName $ dumbbell d0 d0 d0 + Grid{} -> topologyName $ grid d0 d0 + Torus2D{} -> topologyName $ torus2d d0 d0 + Torus3D{} -> topologyName $ torus3d d0 d0 d0 + Tree{} -> topologyName $ tree d0 d0 + Star{} -> topologyName $ star d0 + Cycle{} -> topologyName $ cyclic d0 + Complete{} -> topologyName $ complete d0 + Dumbbell{} -> topologyName $ dumbbell d0 d0 d0 Hourglass{} -> topologyName $ hourglass d0 - Beads{} -> topologyName $ beads d0 d0 d0 - DotFile{} -> "dotfile" - Random{} -> "random" + Beads{} -> topologyName $ beads d0 d0 d0 + DotFile{} -> "dotfile" + Random{} -> "random" -- Unfortunately, we cannot derive 'Eq' and 'Ord' for GADTs. -instance Eq a => Eq (TopologyType m a) where +instance (Eq a) => Eq (TopologyType m a) where x == y = case (x, y) of - (Diamond, Diamond ) -> True - (Pendulum n m, Pendulum n' m' ) -> n == n' && m == m' - (Line n, Line n' ) -> n == n' - (HyperCube n, HyperCube n' ) -> n == n' - (Grid n m, Grid n' m' ) -> n == n' && m == m' - (Torus2D n m, Torus2D n' m' ) -> n == n' && m == m' - (Torus3D n m k, Torus3D n' m' k' ) -> n == n' && m == m' && k == k' - (Tree n m, Tree n' m' ) -> n == n' && m == m' - (Star n, Star n' ) -> n == n' - (Cycle n, Cycle n' ) -> n == n' - (Complete n, Complete n' ) -> n == n' + (Diamond, Diamond) -> True + (Pendulum n m, Pendulum n' m') -> n == n' && m == m' + (Line n, Line n') -> n == n' + (HyperCube n, HyperCube n') -> n == n' + (Grid n m, Grid n' m') -> n == n' && m == m' + (Torus2D n m, Torus2D n' m') -> n == n' && m == m' + (Torus3D n m k, Torus3D n' m' k') -> n == n' && m == m' && k == k' + (Tree n m, Tree n' m') -> n == n' && m == m' + (Star n, Star n') -> n == n' + (Cycle n, Cycle n') -> n == n' + (Complete n, Complete n') -> n == n' (Dumbbell n m k, Dumbbell n' m' k') -> n == n' && m == m' && k == k' - (Hourglass n, Hourglass n' ) -> n == n' - (Beads n m k, Beads n' m' k' ) -> n == n' && m == m' && k == k' - (DotFile p, DotFile p' ) -> p == p' - _ -> False + (Hourglass n, Hourglass n') -> n == n' + (Beads n m k, Beads n' m' k') -> n == n' && m == m' && k == k' + (DotFile p, DotFile p') -> p == p' + _ -> False -instance Ord a => Ord (TopologyType m a) where +instance (Ord a) => Ord (TopologyType m a) where compare x y = case (x, y) of - (Diamond, Diamond ) -> EQ - (Pendulum n m, Pendulum n' m' ) -> compare (n, m) (n', m') - (Line n, Line n' ) -> compare n n' - (HyperCube n, HyperCube n' ) -> compare n n' - (Grid n m, Grid n' m' ) -> compare (n, m) (n', m') - (Torus2D n m, Torus2D n' m' ) -> compare (n, m) (n', m') - (Torus3D n m k, Torus3D n' m' k' ) -> compare (n, m, k) (n', m', k') - (Tree n m, Tree n' m' ) -> compare (n, m) (n', m') - (Star n, Star n' ) -> compare n n' - (Cycle n, Cycle n' ) -> compare n n' - (Complete n, Complete n' ) -> compare n n' + (Diamond, Diamond) -> EQ + (Pendulum n m, Pendulum n' m') -> compare (n, m) (n', m') + (Line n, Line n') -> compare n n' + (HyperCube n, HyperCube n') -> compare n n' + (Grid n m, Grid n' m') -> compare (n, m) (n', m') + (Torus2D n m, Torus2D n' m') -> compare (n, m) (n', m') + (Torus3D n m k, Torus3D n' m' k') -> compare (n, m, k) (n', m', k') + (Tree n m, Tree n' m') -> compare (n, m) (n', m') + (Star n, Star n') -> compare n n' + (Cycle n, Cycle n') -> compare n n' + (Complete n, Complete n') -> compare n n' (Dumbbell n m k, Dumbbell n' m' k') -> compare (n, m, k) (n', m', k') - (Hourglass n, Hourglass n' ) -> compare n n' - (Beads n m k, Beads n' m' k' ) -> compare (n, m, k) (n', m', k') - (DotFile p, DotFile p' ) -> compare p p' - (Random{}, Random{} ) -> LT + (Hourglass n, Hourglass n') -> compare n n' + (Beads n m k, Beads n' m' k') -> compare (n, m, k) (n', m', k') + (DotFile p, DotFile p') -> compare p p' + (Random{}, Random{}) -> LT _ -> compare (ordId x) (ordId y) where ordId = \case - Diamond{} -> 0 :: Int - Pendulum{} -> 1 - Line{} -> 2 + Diamond{} -> 0 :: Int + Pendulum{} -> 1 + Line{} -> 2 HyperCube{} -> 3 - Grid{} -> 4 - Torus2D{} -> 5 - Torus3D{} -> 6 - Tree{} -> 7 - Star{} -> 8 - Cycle{} -> 9 - Complete{} -> 10 - Dumbbell{} -> 11 + Grid{} -> 4 + Torus2D{} -> 5 + Torus3D{} -> 6 + Tree{} -> 7 + Star{} -> 8 + Cycle{} -> 9 + Complete{} -> 10 + Dumbbell{} -> 11 Hourglass{} -> 12 - Beads{} -> 13 - DotFile{} -> 14 - Random{} -> 15 + Beads{} -> 13 + DotFile{} -> 14 + Random{} -> 15 -instance ToJSON a => ToJSON (TopologyType m a) where +instance (ToJSON a) => ToJSON (TopologyType m a) where toJSON t = object $ case t of - Diamond -> [ gt ] - DotFile f -> [ gt, "filepath" .= f ] - Line n -> [ gt, "nodes" .= n ] - HyperCube n -> [ gt, "dimensions" .= n ] - Star n -> [ gt, "nodes" .= n ] - Cycle n -> [ gt, "nodes" .= n ] - Complete n -> [ gt, "nodes" .= n ] - Hourglass n -> [ gt, "nodes" .= n ] - Random n -> [ gt, "nodes" .= n ] - Pendulum l w -> [ gt, "length" .= l, "weight" .= w ] - Tree d c -> [ gt, "depth" .= d, "childs" .= c ] - Grid r c -> [ gt, "rows" .= r, "cols" .= c ] - Torus2D r c -> [ gt, "rows" .= r, "cols" .= c ] - Dumbbell w l r -> [ gt, "width" .= w, "left" .= l, "right" .= r ] - Beads c d w -> [ gt, "count" .= c, "distance" .= d, "weight" .= w ] - Torus3D r c p -> [ gt, "rows" .= r, "cols" .= c, "planes" .= p ] + Diamond -> [gt] + DotFile f -> [gt, "filepath" .= f] + Line n -> [gt, "nodes" .= n] + HyperCube n -> [gt, "dimensions" .= n] + Star n -> [gt, "nodes" .= n] + Cycle n -> [gt, "nodes" .= n] + Complete n -> [gt, "nodes" .= n] + Hourglass n -> [gt, "nodes" .= n] + Random n -> [gt, "nodes" .= n] + Pendulum l w -> [gt, "length" .= l, "weight" .= w] + Tree d c -> [gt, "depth" .= d, "childs" .= c] + Grid r c -> [gt, "rows" .= r, "cols" .= c] + Torus2D r c -> [gt, "rows" .= r, "cols" .= c] + Dumbbell w l r -> [gt, "width" .= w, "left" .= l, "right" .= r] + Beads c d w -> [gt, "count" .= c, "distance" .= d, "weight" .= w] + Torus3D r c p -> [gt, "rows" .= r, "cols" .= c, "planes" .= p] where gt = "graph" .= show t -instance FromJSON a => FromJSON (TopologyType IO a) where +instance (FromJSON a) => FromJSON (TopologyType IO a) where parseJSON v = case v of - Object o -> o .: "graph" >>= \(name :: String) -> case name of - "diamond" -> return Diamond - "dotfile" -> DotFile <$> o .: "filepath" - "line" -> Line <$> o .: "nodes" - "hypercube" -> HyperCube <$> o .: "dimensions" - "star" -> Star <$> o .: "nodes" - "cycle" -> Cycle <$> o .: "nodes" - "complete" -> Complete <$> o .: "nodes" - "hourglass" -> Hourglass <$> o .: "nodes" - "random" -> Random <$> o .: "nodes" - "pendulum" -> Pendulum <$> o .: "length" <*> o .: "weight" - "tree" -> Tree <$> o .: "depth" <*> o .: "childs" - "grid" -> Grid <$> o .: "rows" <*> o .: "cols" - "torus2d" -> Torus2D <$> o .: "rows" <*> o .: "cols" - "torus3d" -> - Torus3D - <$> o .: "rows" - <*> o .: "cols" - <*> o .: "planes" - "dumbbell" -> - Dumbbell - <$> o .: "width" - <*> o .: "left" - <*> o .: "right" - "beads" -> - Beads - <$> o .: "count" - <*> o .: "distance" - <*> o .: "weight" - _ -> tmm + Object o -> + o .: "graph" >>= \(name :: String) -> case name of + "diamond" -> return Diamond + "dotfile" -> DotFile <$> o .: "filepath" + "line" -> Line <$> o .: "nodes" + "hypercube" -> HyperCube <$> o .: "dimensions" + "star" -> Star <$> o .: "nodes" + "cycle" -> Cycle <$> o .: "nodes" + "complete" -> Complete <$> o .: "nodes" + "hourglass" -> Hourglass <$> o .: "nodes" + "random" -> Random <$> o .: "nodes" + "pendulum" -> Pendulum <$> o .: "length" <*> o .: "weight" + "tree" -> Tree <$> o .: "depth" <*> o .: "childs" + "grid" -> Grid <$> o .: "rows" <*> o .: "cols" + "torus2d" -> Torus2D <$> o .: "rows" <*> o .: "cols" + "torus3d" -> + Torus3D + <$> o .: "rows" + <*> o .: "cols" + <*> o .: "planes" + "dumbbell" -> + Dumbbell + <$> o .: "width" + <*> o .: "left" + <*> o .: "right" + "beads" -> + Beads + <$> o .: "count" + <*> o .: "distance" + <*> o .: "weight" + _ -> tmm _ -> tmm where tmm = typeMismatch "Topology" v -newtype FUN a = FUN (forall n . SNat n -> a) +newtype FUN a = FUN (forall n. SNat n -> a) -- | Generates some topology of the given topology type, if possible. fromTopologyType :: (Integral n, Applicative m) => - TopologyType m n -> m (Either String STop) + TopologyType m n -> + m (Either String STop) fromTopologyType tt = case tt of Diamond -> ret $ Just $ STop diamond Pendulum n m -> @@ -315,16 +348,19 @@ fromTopologyType tt = case tt of let beads# :: FUN (FUN (FUN STop)) beads# = FUN (\c@SNat -> FUN (\d@SNat -> FUN (\w@SNat -> STop $ beads c d w))) in ret $ beads# <#> n m k - Random n -> either (return . Left) (Right <$>) $ - maybeToEither $ FUN (\sn@SNat -> STop <$> randomTopology sn) <#> n - DotFile f -> readFile f >>= - return . first (("Invalid DOT file - " <> f <> "\n") <>) . fromDot + Random n -> + either (return . Left) (Right <$>) $ + maybeToEither $ + FUN (\sn@SNat -> STop <$> randomTopology sn) <#> n + DotFile f -> + readFile f + >>= return . first (("Invalid DOT file - " <> f <> "\n") <>) . fromDot where ret = pure . maybeToEither maybeToEither = maybe (Left "cannot construct SNat arguments") Right infixl 8 - () :: Integral i => Maybe (FUN a) -> i -> Maybe a + () :: (Integral i) => Maybe (FUN a) -> i -> Maybe a msnf n = do snf <- msnf SomeNat p <- someNatVal $ toInteger n @@ -332,11 +368,11 @@ fromTopologyType tt = case tt of FUN f -> pure (f (snatProxy p)) infixl 8 <#> - (<#>) :: Integral i => FUN a -> i -> Maybe a + (<#>) :: (Integral i) => FUN a -> i -> Maybe a (<#>) f i = Just f i -- | Given a list of edges, turn it into a directed graph. -fromEdgeList :: forall a. Ord a => [(a, a)] -> Graph +fromEdgeList :: forall a. (Ord a) => [(a, a)] -> Graph fromEdgeList es = dirGraph where -- "Data.Graph" deals with directed graphs @@ -347,7 +383,7 @@ fromEdgeList es = dirGraph -- now that we have a sorted/grouped list of edges, reformat by attaching -- a list of all connected nodes to each node. g :: [(a, b)] -> (a, [b]) - g ps@((x,_):_) = (x, snd <$> ps) + g ps@((x, _) : _) = (x, snd <$> ps) g [] = error "No edges." (dirGraph, _, _) = graphFromEdges ((\(key, keys) -> ((), key, keys)) <$> adjList) @@ -355,95 +391,102 @@ fromEdgeList es = dirGraph -- | @n@ nodes in a line, with a fully connected blob of @m@ nodes at one end. pendulum :: SNat l -> SNat w -> Topology (l + w) pendulum sl sw = - ( dumbbell sl d0 sw ) - { topologyName = "pendulum" - , topologyType = Pendulum (snatToInteger sl) $ snatToInteger sw - } + (dumbbell sl d0 sw) + { topologyName = "pendulum" + , topologyType = Pendulum (snatToInteger sl) $ snatToInteger sw + } --- | @n@ nodes in a line, connected to their neighbors. --- --- (differs from the --- [mathematical terminology](https://mathworld.wolfram.com/LineGraph.html) but --- conforms to callisto) +{- | @n@ nodes in a line, connected to their neighbors. + +(differs from the +[mathematical terminology](https://mathworld.wolfram.com/LineGraph.html) but +conforms to callisto) +-} line :: SNat n -> Topology n line sn = - ( dumbbell sn d0 d0 ) - { topologyName = "line" - , topologyType = Line $ snatToInteger sn - } + (dumbbell sn d0 d0) + { topologyName = "line" + , topologyType = Line $ snatToInteger sn + } -- | @n@-dimensional hypercube hypercube :: SNat n -> Topology (2 ^ n) hypercube sn@SNat = - ( fromGraph "hypercube" $ fromEdgeList es ) - { topologyType = HyperCube $ snatToInteger sn } + (fromGraph "hypercube" $ fromEdgeList es) + { topologyType = HyperCube $ snatToInteger sn + } where n = snatToNum sn - k = (2 :: Int)^n + k = (2 :: Int) ^ n es = -- see Callisto code (julia): -- https://github.com/bittide/Callisto.jl/blob/73d908c6cb02b9b953cc104e5b42d432efc42598/src/topology.jl#L224 - [ let j = i .|. (1 `shiftL` b) in (i+1, j+1) - | i <- [0..(k-1)] - , b <- [0..(n-1)] + [ let j = i .|. (1 `shiftL` b) in (i + 1, j + 1) + | i <- [0 .. (k - 1)] + , b <- [0 .. (n - 1)] , i .&. (1 `shiftL` b) == 0 ] -- | Diamond graph diamond :: Topology 4 diamond = - ( fromGraph "diamond" $ A.listArray (0, 3) [[1,3], [0,2,3], [1,3], [0,1,2]] ) - { topologyType = Diamond } + (fromGraph "diamond" $ A.listArray (0, 3) [[1, 3], [0, 2, 3], [1, 3], [0, 1, 2]]) + { topologyType = Diamond + } -- | Three dimensional torus. torus3d :: SNat a -> SNat b -> SNat c -> Topology (a * b * c) torus3d sna@SNat snb@SNat snc@SNat = - ( fromGraph "torus3d" $ fromEdgeList dirEdges ) - { topologyType = Torus3D a b c } + (fromGraph "torus3d" $ fromEdgeList dirEdges) + { topologyType = Torus3D a b c + } where a = snatToInteger sna b = snatToInteger snb c = snatToInteger snc - pairs = [ (l, m, n) | l <- [0..(a-1)], m <- [0..(b-1)], n <- [0..(c-1)] ] + pairs = [(l, m, n) | l <- [0 .. (a - 1)], m <- [0 .. (b - 1)], n <- [0 .. (c - 1)]] neighborsOf (l, m, n) = - [ ((l-1) `mod` a, m, n) - , ((l+1) `mod` a, m, n) - , (l, (m-1) `mod` b, n) - , (l, (m+1) `mod` b, n) - , (l, m, (n-1) `mod` c) - , (l, m, (n+1) `mod` c) + [ ((l - 1) `mod` a, m, n) + , ((l + 1) `mod` a, m, n) + , (l, (m - 1) `mod` b, n) + , (l, (m + 1) `mod` b, n) + , (l, m, (n - 1) `mod` c) + , (l, m, (n + 1) `mod` c) ] dirEdges = concatMap (\p -> fmap (p,) (neighborsOf p)) pairs -- | See [this figure](https://www.researchgate.net/figure/The-two-dimensional-torus-4x4_fig1_221134153) torus2d :: SNat rows -> SNat cols -> Topology (rows * cols) torus2d snRows@SNat snCols@SNat = - ( fromGraph "torus2d" $ fromEdgeList dirEdges ) - { topologyType = Torus2D rows cols } + (fromGraph "torus2d" $ fromEdgeList dirEdges) + { topologyType = Torus2D rows cols + } where rows = snatToInteger snRows cols = snatToInteger snCols - pairs = [ (m, n) | m <- [0..(rows-1)], n <- [0..(cols-1)] ] + pairs = [(m, n) | m <- [0 .. (rows - 1)], n <- [0 .. (cols - 1)]] neighborsOf (m, n) = - [ ((m-1) `mod` rows, n) - , ((m+1) `mod` rows, n) - , (m, (n-1) `mod` cols) - , (m, (n+1) `mod` cols) + [ ((m - 1) `mod` rows, n) + , ((m + 1) `mod` rows, n) + , (m, (n - 1) `mod` cols) + , (m, (n + 1) `mod` cols) ] dirEdges = concatMap (\p -> fmap (p,) (neighborsOf p)) pairs -- | [Grid graph](https://mathworld.wolfram.com/GridGraph.html) grid :: SNat rows -> SNat cols -> Topology (rows * cols) grid snRows@SNat snCols@SNat = - ( fromGraph "grid" $ fromEdgeList dirEdges ) - { topologyType = Grid rows cols } + (fromGraph "grid" $ fromEdgeList dirEdges) + { topologyType = Grid rows cols + } where rows = snatToInteger snRows cols = snatToInteger snCols - pairs = [ (m, n) | m <- [1..rows], n <- [1..cols] ] + pairs = [(m, n) | m <- [1 .. rows], n <- [1 .. cols]] mkEdges (m, n) = [ (a, b) - | a <- [(m-1)..(m+1)], b <- [(n-1)..(n+1)] + | a <- [(m - 1) .. (m + 1)] + , b <- [(n - 1) .. (n + 1)] , a /= m || b /= n , a == m || b == n , a > 0 @@ -455,8 +498,8 @@ grid snRows@SNat snCols@SNat = -- | Type family for calculating the size of a tree. type family TreeSize (depth :: Nat) (children :: Nat) where - TreeSize depth 0 = 1 - TreeSize depth 1 = depth + 1 + TreeSize depth 0 = 1 + TreeSize depth 1 = depth + 1 TreeSize depth children = Div ((children ^ (depth + 1)) - 1) (children - 1) @@ -466,64 +509,68 @@ instance (KnownNat n, KnownNat m) => KnownNat2 $(nameToSymbol ''TreeSize) n m wh x = natVal (Proxy @n) y = natVal (Proxy @m) z = treeSize x y - in + in SNatKn z where - treeSize :: Natural -> Natural -> Natural - treeSize d = \case - 0 -> 1 - 1 -> d + 1 - c -> ((c ^ (d + 1)) - 1) `div` (c - 1) + treeSize :: Natural -> Natural -> Natural + treeSize d = \case + 0 -> 1 + 1 -> d + 1 + c -> ((c ^ (d + 1)) - 1) `div` (c - 1) {-# INLINE natSing2 #-} -- | Tree of depth @depth@ with @childs@ children tree :: SNat depth -> SNat childs -> Topology (TreeSize depth childs) tree snDepth@SNat snChilds@SNat = - ( fromGraph "tree" treeGraph ) - { topologyType = Tree depth c } + (fromGraph "tree" treeGraph) + { topologyType = Tree depth c + } where depth = snatToInteger snDepth c = snatToInteger snChilds - -- | At depth @d_i@, child node @i@ is connected to the @(i-1) `div` c + 1@st + -- \| At depth @d_i@, child node @i@ is connected to the @(i-1) `div` c + 1@st -- node at depth @d_i - 1@ - pairs = [ (d_i, i, (i-1) `div` c + 1) | d_i <- [0..depth], i <- [1..(c^d_i)] ] - mkEdges (0, _, _) = Nothing - mkEdges (lvl, node, p_node) = Just ((lvl, node), (lvl-1, p_node)) + pairs = [(d_i, i, (i - 1) `div` c + 1) | d_i <- [0 .. depth], i <- [1 .. (c ^ d_i)]] + mkEdges (0, _, _) = Nothing + mkEdges (lvl, node, p_node) = Just ((lvl, node), (lvl - 1, p_node)) directedEdges = mapMaybe mkEdges pairs treeGraph = fromEdgeList directedEdges -- | [Star graph](https://mathworld.wolfram.com/StarGraph.html) star :: SNat childs -> Topology (TreeSize 1 childs) star sn = - ( tree SNat sn ) - { topologyName = "star" - , topologyType = Star $ snatToInteger sn - } + (tree SNat sn) + { topologyName = "star" + , topologyType = Star $ snatToInteger sn + } --- | [Cyclic graph](https://mathworld.wolfram.com/CycleGraph.html) with @n@ --- vertices. +{- | [Cyclic graph](https://mathworld.wolfram.com/CycleGraph.html) with @n@ +vertices. +-} cyclic :: SNat n -> Topology n cyclic sn = - ( beads sn d0 d1 ) - { topologyName = "cycle" - , topologyType = Cycle $ snatToInteger sn - } + (beads sn d0 d1) + { topologyName = "cycle" + , topologyType = Cycle $ snatToInteger sn + } --- | [Complete graph](https://mathworld.wolfram.com/CompleteGraph.html) with @n@ --- vertices. +{- | [Complete graph](https://mathworld.wolfram.com/CompleteGraph.html) with @n@ +vertices. +-} complete :: SNat n -> Topology n complete sn = - ( beads d1 d0 sn ) - { topologyName = "complete" - , topologyType = Complete $ snatToInteger sn - } + (beads d1 d0 sn) + { topologyName = "complete" + , topologyType = Complete $ snatToInteger sn + } --- | An dumbbell shaped graph consisting of two independent complete --- sub-graphs of size @l@ and @r@, connected via a chain of @w@ nodes --- in between two distinct nodes of each sub-graph. +{- | An dumbbell shaped graph consisting of two independent complete +sub-graphs of size @l@ and @r@, connected via a chain of @w@ nodes +in between two distinct nodes of each sub-graph. +-} dumbbell :: SNat w -> SNat l -> SNat r -> Topology (w + l + r) dumbbell sw@SNat sl@SNat sr@SNat = - t { topologyType = Dumbbell (sn2i sw) (sn2i sl) (sn2i sr) } + t{topologyType = Dumbbell (sn2i sw) (sn2i sl) (sn2i sr)} where sn2i = snatToInteger w = snatToNum sw @@ -531,459 +578,553 @@ dumbbell sw@SNat sl@SNat sr@SNat = r = snatToNum sr m = w + l + r - 1 - t = fromGraph "dumbbell" $ - if w + l + r == 0 - then A.array (0,-1) [] - else A.array (0, m) $ fmap (\i -> (i, neighbours i)) [0..m] + t = + fromGraph "dumbbell" $ + if w + l + r == 0 + then A.array (0, -1) [] + else A.array (0, m) $ fmap (\i -> (i, neighbours i)) [0 .. m] neighbours i - | i < l = - (if i == l - 1 && w + r > 0 then (l :) else id) - [ j | j <- [0..l - 1], j /= i ] + | i < l = + (if i == l - 1 && w + r > 0 then (l :) else id) + [j | j <- [0 .. l - 1], j /= i] | i >= w + l = - (if i == w + l && w + l > 0 then ((w + l - 1) :) else id) - [ j + w + l | j <- [0..r - 1], j + w + l /= i ] + (if i == w + l && w + l > 0 then ((w + l - 1) :) else id) + [j + w + l | j <- [0 .. r - 1], j + w + l /= i] | otherwise = - (if l > 0 || i > l then ((i - 1) :) else id) - $ (if r > 0 || i < l + w - 1 then ((i + 1) :) else id) - [] + (if l > 0 || i > l then ((i - 1) :) else id) $ + (if r > 0 || i < l + w - 1 then ((i + 1) :) else id) + [] --- | An hourglass shaped graph consisting of two independent complete --- sub-graphs, only connected via a single edge between two distinct --- nodes of each sub-graph. +{- | An hourglass shaped graph consisting of two independent complete +sub-graphs, only connected via a single edge between two distinct +nodes of each sub-graph. +-} hourglass :: SNat n -> Topology (n + n) hourglass sn = - ( dumbbell d0 sn sn ) - { topologyName = "hourglass" - , topologyType = Hourglass $ snatToInteger sn - } + (dumbbell d0 sn sn) + { topologyName = "hourglass" + , topologyType = Hourglass $ snatToInteger sn + } --- | A beads shaped graph consisting of two @c@ independend complete --- subgraphs of size @w@ (representing the beads), connected via a --- closed circular chain of @d@ nodes in between (representing the --- thread). +{- | A beads shaped graph consisting of two @c@ independend complete +subgraphs of size @w@ (representing the beads), connected via a +closed circular chain of @d@ nodes in between (representing the +thread). +-} beads :: SNat c -> SNat d -> SNat w -> Topology (c * (d + w)) beads sc@SNat sd@SNat sw@SNat = - ( fromGraph "beads" $ fromEdgeList es ) - { topologyType = Beads (sn2i sc) (sn2i sd) (sn2i sw) } + (fromGraph "beads" $ fromEdgeList es) + { topologyType = Beads (sn2i sc) (sn2i sd) (sn2i sw) + } where sn2i = snatToInteger c = snatToNum sc :: Int d = snatToNum sd :: Int w = snatToNum sw :: Int s = c * (d + w) - es = [ (x + i, x + j) - | n <- [0..c - 1] - , i <- [0..w - 1] - , j <- [0..w - 1] - , i /= j - , let x = n * (d + w) - ] - <> [ (x', x) - | w > 0 - , n <- [0..c - 1] - , let x' = n * (d + w) - x = (x' - 1) `mod` s - , x /= x' - ] - <> [ (x', x) - | n <- [0..c - 1] - , i <- [0..d - 1] - , let x' = n * (d + w) + w + i - x = (x' - 1) `mod` s - , x /= x' - ] + es = + [ (x + i, x + j) + | n <- [0 .. c - 1] + , i <- [0 .. w - 1] + , j <- [0 .. w - 1] + , i /= j + , let x = n * (d + w) + ] + <> [ (x', x) + | w > 0 + , n <- [0 .. c - 1] + , let x' = n * (d + w) + x = (x' - 1) `mod` s + , x /= x' + ] + <> [ (x', x) + | n <- [0 .. c - 1] + , i <- [0 .. d - 1] + , let x' = n * (d + w) + w + i + x = (x' - 1) `mod` s + , x /= x' + ] -- | Command line parser for the different topology types. topTypeCLIParser :: Parser (TopologyType IO Integer) -topTypeCLIParser = hsubparser - ( commandGroup "Available topologies:" - <> metavar "TOPOLOGY" - <> command (show Diamond) - ( info - ( pure Diamond - ) - $ progDesc "diamond graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like:" - , "" - , " o" - , " / \\" - , " o---o" - , " \\ /" - , " o" - ] - ) - ) - <> command (show $ Pendulum () ()) - ( info - ( Pendulum - <$> option auto - ( long "length" - <> short 'L' - <> metavar "NUM" - <> help "number of nodes representing the thread" - ) - <*> option auto - ( long "weight" - <> short 'W' - <> metavar "NUM" - <> help "number of nodes representing the weight" - ) - ) $ progDesc "pendulum shaped graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for LENGTH = 2, WEIGHT = 4)" - , "" - , " o" - , " |" - , " o" - , " |" - , " o" - , " /|\\" - , " o-+-o" - , " \\|/" - , " o" - ] - ) - ) - <> command (show $ Line ()) - ( info - ( Line <$> option auto - ( long "nodes" - <> short 'N' - <> metavar "NUM" - <> help "number of nodes of the graph" - ) - ) - $ progDesc "line graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for NODES = 3)" - , "" - , " o---o---o" - ] - ) - ) - <> command (show $ HyperCube ()) - ( info - ( HyperCube <$> option auto - ( long "dimensions" - <> short 'N' - <> metavar "NUM" - <> help "number of dimensions" - ) - ) - $ progDesc "hyper cube" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for DIMENSIONS = 3)" - , "" - , " o---o" - , " /| /|" - , " o---o |" - , " | o-|-o" - , " |/ |/" - , " o---o" - ] - ) - ) - <> command (show $ Grid () ()) - ( info - ( Grid - <$> option auto - ( long "rows" - <> short 'R' - <> metavar "NUM" - <> help "number of rows" - ) - <*> option auto - ( long "cols" - <> short 'C' - <> metavar "NUM" - <> help "number of columns" - ) - ) $ progDesc "2-dimensional grid" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for ROWS = 3, COLS = 4)" - , "" - , " o---o---o---o" - , " | | | |" - , " o---o---o---o" - , " | | | |" - , " o---o---o---o" - ] - ) - ) - <> command (show $ Torus2D () ()) - ( info - ( Torus2D - <$> option auto - ( long "rows" - <> short 'R' - <> metavar "NUM" - <> help "number of rows" - ) - <*> option auto - ( long "cols" - <> short 'C' - <> metavar "NUM" - <> help "number of columns" - ) - ) - $ progDesc "2-dimensional torus" - <> footerDoc - ( Just $ pretty $ unlines - [ "c.f. https://www.researchgate.net/figure/" - <> "The-two-dimensional-torus-4x4_fig1_221134153" - ] - ) - ) - <> command (show $ Torus3D () () ()) - ( info - ( Torus3D - <$> option auto - ( long "rows" - <> short 'R' - <> metavar "NUM" - <> help "number of rows" - ) - <*> option auto - ( long "cols" - <> short 'C' - <> metavar "NUM" - <> help "number of columns" - ) - <*> option auto - ( long "planes" - <> short 'P' - <> metavar "NUM" - <> help "number of planes" - ) - ) $ progDesc "3-dimensional torus" - <> footerDoc - ( Just $ pretty $ unlines - [ "c.f. https://upload.wikimedia.org/wikipedia/" - <> "commons/thumb/3/3f/2x2x2torus.svg/" - <> "220px-2x2x2torus.svg.png" - ] - ) - ) - <> command (show $ Tree () ()) - ( info - ( Tree - <$> option auto - ( long "depth" - <> short 'D' - <> metavar "NUM" - <> help "depth of the tree" - ) - <*> option auto - ( long "childs" - <> short 'C' - <> metavar "NUM" - <> help "number of children" - ) - ) $ progDesc "balanced tree" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for CHILDS = 2, DEPTH = 2)" - , "" - , " o" - , " / \\" - , " o o" - , " /| |\\" - , " o o o o" - ] - ) - ) - <> command (show $ Star ()) - ( info - ( Star <$> option auto - ( long "nodes" - <> short 'N' - <> metavar "NUM" - <> help "number of non-central nodes of the graph" - ) - ) $ progDesc "star shaped graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for NODES = 8)" - , "" - , " o o o" - , " \\|/" - , " o--o--o" - , " /|\\" - , " o o o" - ] - ) - ) - <> command (show $ Cycle ()) - ( info - ( Cycle <$> option auto - ( long "nodes" - <> short 'N' - <> metavar "NUM" - <> help "number of nodes of the graph" - ) - ) $ progDesc "cycle shaped graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for NODES = 6)" - , "" - , " o--o" - , " / \\" - , " o o" - , " \\ /" - , " o--o" - ] - ) - ) - <> command (show $ Complete ()) - ( info - ( Complete <$> option auto - ( long "nodes" - <> short 'N' - <> metavar "NUM" - <> help "number of nodes of the graph" - ) - ) $ progDesc "fully connected graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for NODES = 4)" - , "" - , " o" - , " /|\\" - , " o-+-o" - , " \\|/" - , " o" - ] - ) - ) - <> command (show $ Dumbbell () () ()) - ( info - ( Dumbbell - <$> option auto - ( long "width" - <> short 'W' - <> metavar "NUM" - <> help "number of nodes representing the thread" - ) - <*> option auto - ( long "left" - <> short 'L' - <> metavar "NUM" - <> help "number of nodes representing the left weight" - ) - <*> option auto - ( long "right" - <> short 'R' - <> metavar "NUM" - <> help "number of nodes representing the right weight" - ) - ) $ progDesc "dumbbell shaped graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for WIDTH = 2, LEFT = 3, RIGHT = 4)" - , "" - , " o o" - , " |\\ /|\\" - , " | o--o--o--o-+-o" - , " |/ \\|/" - , " o o" - ] - ) - ) - <> command (show $ Hourglass ()) - ( info - ( Hourglass <$> option auto - ( long "nodes" - <> short 'n' - <> metavar "NUM" - <> help "number of nodes in one half of the hourglass" - ) - ) $ progDesc "hourglass shaped graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for NODES = 3)" - , "" - , " o---o" - , " \\ /" - , " o" - , " |" - , " o" - , " / \\" - , " o---o" - ] - ) - ) - <> command (show $ Beads () () ()) - ( info - ( Beads - <$> option auto - ( long "count" - <> short 'C' - <> metavar "NUM" - <> help "number of beads" - ) - <*> option auto - ( long "distance" - <> short 'D' - <> metavar "NUM" - <> help "number of nodes in between two beads" - ) - <*> option auto - ( long "weight" - <> short 'W' - <> metavar "NUM" - <> help "number of nodes representing a bead" - ) - ) $ progDesc "beads shaped graph" - <> footerDoc - ( Just $ pretty $ unlines - [ "looks like: (for COUNT = 3, DISTANCE = 1, WEIGHT = 3)" - , "" - , " o---o" - , " / \\ / \\" - , " o o o" - , " / \\" - , " o---o o---o" - , " \\ / \\ /" - , " o---o---o" - ] - ) - ) - <> command (show $ Random ()) - ( info - ( Random <$> option auto - ( long "nodes" - <> short 'n' - <> metavar "NUM" - <> help "number of nodes of the graph" - ) - ) $ progDesc "random connected graph" - ) - <> command (show $ DotFile "") - ( info - ( DotFile <$> strOption - ( long "dot" - <> short 'd' - <> metavar "FILE" - <> action "file" - <> help "GraphViz DOT file" - ) - ) $ progDesc "GraphViz DOT graph" - ) - ) +topTypeCLIParser = + hsubparser + ( commandGroup "Available topologies:" + <> metavar "TOPOLOGY" + <> command + (show Diamond) + ( info + ( pure Diamond + ) + $ progDesc "diamond graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like:" + , "" + , " o" + , " / \\" + , " o---o" + , " \\ /" + , " o" + ] + ) + ) + <> command + (show $ Pendulum () ()) + ( info + ( Pendulum + <$> option + auto + ( long "length" + <> short 'L' + <> metavar "NUM" + <> help "number of nodes representing the thread" + ) + <*> option + auto + ( long "weight" + <> short 'W' + <> metavar "NUM" + <> help "number of nodes representing the weight" + ) + ) + $ progDesc "pendulum shaped graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for LENGTH = 2, WEIGHT = 4)" + , "" + , " o" + , " |" + , " o" + , " |" + , " o" + , " /|\\" + , " o-+-o" + , " \\|/" + , " o" + ] + ) + ) + <> command + (show $ Line ()) + ( info + ( Line + <$> option + auto + ( long "nodes" + <> short 'N' + <> metavar "NUM" + <> help "number of nodes of the graph" + ) + ) + $ progDesc "line graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for NODES = 3)" + , "" + , " o---o---o" + ] + ) + ) + <> command + (show $ HyperCube ()) + ( info + ( HyperCube + <$> option + auto + ( long "dimensions" + <> short 'N' + <> metavar "NUM" + <> help "number of dimensions" + ) + ) + $ progDesc "hyper cube" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for DIMENSIONS = 3)" + , "" + , " o---o" + , " /| /|" + , " o---o |" + , " | o-|-o" + , " |/ |/" + , " o---o" + ] + ) + ) + <> command + (show $ Grid () ()) + ( info + ( Grid + <$> option + auto + ( long "rows" + <> short 'R' + <> metavar "NUM" + <> help "number of rows" + ) + <*> option + auto + ( long "cols" + <> short 'C' + <> metavar "NUM" + <> help "number of columns" + ) + ) + $ progDesc "2-dimensional grid" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for ROWS = 3, COLS = 4)" + , "" + , " o---o---o---o" + , " | | | |" + , " o---o---o---o" + , " | | | |" + , " o---o---o---o" + ] + ) + ) + <> command + (show $ Torus2D () ()) + ( info + ( Torus2D + <$> option + auto + ( long "rows" + <> short 'R' + <> metavar "NUM" + <> help "number of rows" + ) + <*> option + auto + ( long "cols" + <> short 'C' + <> metavar "NUM" + <> help "number of columns" + ) + ) + $ progDesc "2-dimensional torus" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "c.f. https://www.researchgate.net/figure/" + <> "The-two-dimensional-torus-4x4_fig1_221134153" + ] + ) + ) + <> command + (show $ Torus3D () () ()) + ( info + ( Torus3D + <$> option + auto + ( long "rows" + <> short 'R' + <> metavar "NUM" + <> help "number of rows" + ) + <*> option + auto + ( long "cols" + <> short 'C' + <> metavar "NUM" + <> help "number of columns" + ) + <*> option + auto + ( long "planes" + <> short 'P' + <> metavar "NUM" + <> help "number of planes" + ) + ) + $ progDesc "3-dimensional torus" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "c.f. https://upload.wikimedia.org/wikipedia/" + <> "commons/thumb/3/3f/2x2x2torus.svg/" + <> "220px-2x2x2torus.svg.png" + ] + ) + ) + <> command + (show $ Tree () ()) + ( info + ( Tree + <$> option + auto + ( long "depth" + <> short 'D' + <> metavar "NUM" + <> help "depth of the tree" + ) + <*> option + auto + ( long "childs" + <> short 'C' + <> metavar "NUM" + <> help "number of children" + ) + ) + $ progDesc "balanced tree" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for CHILDS = 2, DEPTH = 2)" + , "" + , " o" + , " / \\" + , " o o" + , " /| |\\" + , " o o o o" + ] + ) + ) + <> command + (show $ Star ()) + ( info + ( Star + <$> option + auto + ( long "nodes" + <> short 'N' + <> metavar "NUM" + <> help "number of non-central nodes of the graph" + ) + ) + $ progDesc "star shaped graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for NODES = 8)" + , "" + , " o o o" + , " \\|/" + , " o--o--o" + , " /|\\" + , " o o o" + ] + ) + ) + <> command + (show $ Cycle ()) + ( info + ( Cycle + <$> option + auto + ( long "nodes" + <> short 'N' + <> metavar "NUM" + <> help "number of nodes of the graph" + ) + ) + $ progDesc "cycle shaped graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for NODES = 6)" + , "" + , " o--o" + , " / \\" + , " o o" + , " \\ /" + , " o--o" + ] + ) + ) + <> command + (show $ Complete ()) + ( info + ( Complete + <$> option + auto + ( long "nodes" + <> short 'N' + <> metavar "NUM" + <> help "number of nodes of the graph" + ) + ) + $ progDesc "fully connected graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for NODES = 4)" + , "" + , " o" + , " /|\\" + , " o-+-o" + , " \\|/" + , " o" + ] + ) + ) + <> command + (show $ Dumbbell () () ()) + ( info + ( Dumbbell + <$> option + auto + ( long "width" + <> short 'W' + <> metavar "NUM" + <> help "number of nodes representing the thread" + ) + <*> option + auto + ( long "left" + <> short 'L' + <> metavar "NUM" + <> help "number of nodes representing the left weight" + ) + <*> option + auto + ( long "right" + <> short 'R' + <> metavar "NUM" + <> help "number of nodes representing the right weight" + ) + ) + $ progDesc "dumbbell shaped graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for WIDTH = 2, LEFT = 3, RIGHT = 4)" + , "" + , " o o" + , " |\\ /|\\" + , " | o--o--o--o-+-o" + , " |/ \\|/" + , " o o" + ] + ) + ) + <> command + (show $ Hourglass ()) + ( info + ( Hourglass + <$> option + auto + ( long "nodes" + <> short 'n' + <> metavar "NUM" + <> help "number of nodes in one half of the hourglass" + ) + ) + $ progDesc "hourglass shaped graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for NODES = 3)" + , "" + , " o---o" + , " \\ /" + , " o" + , " |" + , " o" + , " / \\" + , " o---o" + ] + ) + ) + <> command + (show $ Beads () () ()) + ( info + ( Beads + <$> option + auto + ( long "count" + <> short 'C' + <> metavar "NUM" + <> help "number of beads" + ) + <*> option + auto + ( long "distance" + <> short 'D' + <> metavar "NUM" + <> help "number of nodes in between two beads" + ) + <*> option + auto + ( long "weight" + <> short 'W' + <> metavar "NUM" + <> help "number of nodes representing a bead" + ) + ) + $ progDesc "beads shaped graph" + <> footerDoc + ( Just $ + pretty $ + unlines + [ "looks like: (for COUNT = 3, DISTANCE = 1, WEIGHT = 3)" + , "" + , " o---o" + , " / \\ / \\" + , " o o o" + , " / \\" + , " o---o o---o" + , " \\ / \\ /" + , " o---o---o" + ] + ) + ) + <> command + (show $ Random ()) + ( info + ( Random + <$> option + auto + ( long "nodes" + <> short 'n' + <> metavar "NUM" + <> help "number of nodes of the graph" + ) + ) + $ progDesc "random connected graph" + ) + <> command + (show $ DotFile "") + ( info + ( DotFile + <$> strOption + ( long "dot" + <> short 'd' + <> metavar "FILE" + <> action "file" + <> help "GraphViz DOT file" + ) + ) + $ progDesc "GraphViz DOT graph" + ) + ) -- | Generates a random topology of the given size. randomTopology :: SNat n -> IO (Topology n) randomTopology sn@SNat = do let n = snatToNum sn - is = [0,1..n - 1] + is = [0, 1 .. n - 1] -- get some random vertex permuation for ensuring connectivity aP <- newListArray (0, n - 1) is @@ -1017,21 +1158,25 @@ randomTopology sn@SNat = do available <- freeze (aE :: IOUArray (Int, Int) Bool) -- create the graph - return $ fromGraph "random" $ buildG (0, n - 1) - [ (i, j) - | i <- is - , j <- is - , available A.! (i, j) - ] + return $ + fromGraph "random" $ + buildG + (0, n - 1) + [ (i, j) + | i <- is + , j <- is + , available A.! (i, j) + ] --- | Turns a topology into a graphviz DOT structure, as it is required by --- the [happy-dot](https://hackage.haskell.org/package/happy-dot) library. +{- | Turns a topology into a graphviz DOT structure, as it is required by +the [happy-dot](https://hackage.haskell.org/package/happy-dot) library. +-} toDot :: - KnownNat n => + (KnownNat n) => + -- | topology to be turned into graphviz dot Topology n -> - -- ^ topology to be turned into graphviz dot + -- | the result, as it is needed by happy-dot (Bool, GraphType, Maybe Name, [Statement]) - -- ^ the result, as it is needed by happy-dot toDot t = ( True , Graph @@ -1039,17 +1184,20 @@ toDot t = , map asEdgeStatement $ edges $ topologyGraph t ) where - asEdgeStatement (x, y) = EdgeStatement - (map (\i -> NodeRef (XMLID ('n' : show i)) Nothing) [x,y]) [] + asEdgeStatement (x, y) = + EdgeStatement + (map (\i -> NodeRef (XMLID ('n' : show i)) Nothing) [x, y]) + [] --- | Reads a topology from a DOT file. Only the name and structure of the --- graph is used, i.e., any additional graphviz dot specific --- annotations are ignored. +{- | Reads a topology from a DOT file. Only the name and structure of the +graph is used, i.e., any additional graphviz dot specific +annotations are ignored. +-} fromDot :: - String - -- ^ the string holding the graphviz dot content - -> Either String STop - -- ^ either an error, if given an unusable input, or the extracted topology + -- | the string holding the graphviz dot content + String -> + -- | either an error, if given an unusable input, or the extracted topology + Either String STop fromDot cnt = do (strict, gType, maybe "" fromDotName -> name, statements) <- parse cnt @@ -1062,19 +1210,23 @@ fromDot cnt = do namedEdges = concatMap (pairwise . map asString) edgeChains edgeNames = dedupAndSort $ concatMap (\(x, y) -> [x, y]) namedEdges n = length edgeNames - idx = (M.!) $ M.fromList $ zip edgeNames [0,1..] - graph = buildG (0,n-1) + idx = (M.!) $ M.fromList $ zip edgeNames [0, 1 ..] + graph = + buildG (0, n - 1) -- Self loops are removed at this point as they are redundant in -- terms of the simulated topology. In terms of connectivity, a -- node can synchronize its clock with itself even without a -- elastic buffer in between. Therefore, we all self-loops in -- the input, but remove them here, since they don't have any -- effect on the topology that is created out of the graph. - $ filter (uncurry (/=)) - -- remove duplicate edges and sort for pretty printing - $ dedupAndSort - $ concatMap (\(x, y) -> [(idx x, idx y), (idx y, idx x)]) - namedEdges + $ + filter (uncurry (/=)) + -- remove duplicate edges and sort for pretty printing + $ + dedupAndSort $ + concatMap + (\(x, y) -> [(idx x, idx y), (idx y, idx x)]) + namedEdges when (length (scc graph) > 1) $ Left "Graph must be strongly connected" @@ -1087,27 +1239,28 @@ fromDot cnt = do fromStatement = \case EdgeStatement xs _ -> fmap Just $ forM xs $ \case NodeRef n _ -> return n - Subgraph{} -> Left "Subgraphs are not supported" + Subgraph{} -> Left "Subgraphs are not supported" -- we are only interested in the edges, everthing else can be -- ignored _ -> pure Nothing - dedupAndSort :: Ord a => [a] -> [a] + dedupAndSort :: (Ord a) => [a] -> [a] dedupAndSort = S.toList . S.fromList asString = \case StringID x -> 's' : x - XMLID x -> 'x' : x + XMLID x -> 'x' : x fromDotName = \case StringID x -> x - XMLID x -> x + XMLID x -> x --- | Successive overlapping pairs. --- --- >>> pairwise [1, 2, 3, 4] --- [(1,2),(2,3),(3,4)] --- >>> pairwise [] --- [] -pairwise :: [a] -> [(a,a)] +{- | Successive overlapping pairs. + +>>> pairwise [1, 2, 3, 4] +[(1,2),(2,3),(3,4)] +>>> pairwise [] +[] +-} +pairwise :: [a] -> [(a, a)] pairwise as = zip as (tail as) diff --git a/bittide-experiments/tests/Tests/Bittide/Simulate.hs b/bittide-experiments/tests/Tests/Bittide/Simulate.hs index 956b0a981..6a482454b 100644 --- a/bittide-experiments/tests/Tests/Bittide/Simulate.hs +++ b/bittide-experiments/tests/Tests/Bittide/Simulate.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -10,23 +9,26 @@ module Tests.Bittide.Simulate where import Clash.Explicit.Prelude +import Data.Maybe import Test.Tasty import Test.Tasty.HUnit -import Data.Maybe import Bittide.ClockControl import Bittide.ClockControl.Callisto -createDomain vXilinxSystem{vPeriod=hzToPeriod 200e6, vName="Fast"} -createDomain vXilinxSystem{vPeriod=hzToPeriod 20e6, vName="Slow"} +createDomain vXilinxSystem{vPeriod = hzToPeriod 200e6, vName = "Fast"} +createDomain vXilinxSystem{vPeriod = hzToPeriod 20e6, vName = "Slow"} tests :: TestTree -tests = testGroup "Simulate" - [ testGroup "elasticBuffer" - [ testCase "case_caseClockControlMaxBound" case_clockControlMaxBound - , testCase "case_caseClockControlMinBound" case_clockControlMinBound +tests = + testGroup + "Simulate" + [ testGroup + "elasticBuffer" + [ testCase "case_caseClockControlMaxBound" case_clockControlMaxBound + , testCase "case_caseClockControlMinBound" case_clockControlMinBound + ] ] - ] case_clockControlMaxBound :: Assertion case_clockControlMaxBound = do @@ -35,10 +37,11 @@ case_clockControlMaxBound = do dataCounts = pure maxBound :> Nil mask = pure $ pack (repeat high) changes = - fmap (fromMaybe NoChange . maybeSpeedChange) $ sampleN - -- +10_000 assumes callisto's pipeline less than 10_000 deep - (fromIntegral (cccPessimisticSettleCycles config + 10_000)) - (callistoClockControl @_ @_ @Fast clockGen resetGen enableGen config mask dataCounts) + fmap (fromMaybe NoChange . maybeSpeedChange) + $ sampleN + -- +10_000 assumes callisto's pipeline less than 10_000 deep + (fromIntegral (cccPessimisticSettleCycles config + 10_000)) + (callistoClockControl @_ @_ @Fast clockGen resetGen enableGen config mask dataCounts) assertBool "only requests speed up" @@ -51,10 +54,11 @@ case_clockControlMinBound = do dataCounts = pure minBound :> Nil mask = pure $ pack (repeat high) changes = - fmap (fromMaybe NoChange . maybeSpeedChange) $ sampleN - -- +100 assumes callisto's pipeline less than 100 deep - (fromIntegral (cccPessimisticSettleCycles config + 100)) - (callistoClockControl @_ @_ @Fast clockGen resetGen enableGen config mask dataCounts) + fmap (fromMaybe NoChange . maybeSpeedChange) + $ sampleN + -- +100 assumes callisto's pipeline less than 100 deep + (fromIntegral (cccPessimisticSettleCycles config + 100)) + (callistoClockControl @_ @_ @Fast clockGen resetGen enableGen config mask dataCounts) assertBool "only requests slow down" diff --git a/bittide-experiments/tests/doctests.hs b/bittide-experiments/tests/doctests.hs index 1a01c778c..c1b610a22 100644 --- a/bittide-experiments/tests/doctests.hs +++ b/bittide-experiments/tests/doctests.hs @@ -4,11 +4,11 @@ module Main (main) where -import Test.DocTest (mainFromCabal) import System.Environment (getArgs) +import Test.DocTest (mainFromCabal) main :: IO () main = do -- We use Nix to setup tooling, not to provide GHC packages so we need to set --no-nix args <- getArgs - mainFromCabal "bittide-experiments" ("--no-nix":args) + mainFromCabal "bittide-experiments" ("--no-nix" : args) diff --git a/bittide-experiments/tests/unittests.hs b/bittide-experiments/tests/unittests.hs index 034a60e8d..a84f7c5dd 100644 --- a/bittide-experiments/tests/unittests.hs +++ b/bittide-experiments/tests/unittests.hs @@ -4,17 +4,19 @@ module Main where -import Prelude import Test.Tasty +import Prelude import Tests.Bittide.Simulate qualified tests :: TestTree tests = - testGroup "Tests" - [ testGroup "Bittide" - [ Tests.Bittide.Simulate.tests - ] + testGroup + "Tests" + [ testGroup + "Bittide" + [ Tests.Bittide.Simulate.tests + ] ] main :: IO () diff --git a/bittide-extra/src/Bittide/Extra/Maybe.hs b/bittide-extra/src/Bittide/Extra/Maybe.hs index e5e9c4943..8f2624b48 100644 --- a/bittide-extra/src/Bittide/Extra/Maybe.hs +++ b/bittide-extra/src/Bittide/Extra/Maybe.hs @@ -11,37 +11,38 @@ import Data.Maybe >>> import Clash.Prelude -} --- | Extract `Just` from a `Vec` of `Maybe`s. Prefer left-most `Just`. If no `Just` is --- found, use a default value. --- --- >>> fromMaybesL 0 (Just 1 :> Just 2 :> Nothing :> Nil) --- 1 --- >>> fromMaybesL 0 (Nothing :> Nothing :> Nothing :> Nil) --- 0 --- +{- | Extract `Just` from a `Vec` of `Maybe`s. Prefer left-most `Just`. If no `Just` is +found, use a default value. + +>>> fromMaybesL 0 (Just 1 :> Just 2 :> Nothing :> Nil) +1 +>>> fromMaybesL 0 (Nothing :> Nothing :> Nothing :> Nil) +0 +-} fromMaybesL :: a -> Vec n (Maybe a) -> a fromMaybesL a = fromMaybe a . fold (<|>) . (Nothing :>) --- | Extract `Just` from a `Vec` of `Maybe`s. Prefer right-most `Just`. If no `Just` is --- found, use a default value. --- --- >>> fromMaybesR 0 (Just 1 :> Just 2 :> Nothing :> Nil) --- 2 --- >>> fromMaybesR 0 (Nothing :> Nothing :> Nothing :> Nil) --- 0 --- +{- | Extract `Just` from a `Vec` of `Maybe`s. Prefer right-most `Just`. If no `Just` is +found, use a default value. + +>>> fromMaybesR 0 (Just 1 :> Just 2 :> Nothing :> Nil) +2 +>>> fromMaybesR 0 (Nothing :> Nothing :> Nothing :> Nil) +0 +-} fromMaybesR :: a -> Vec n (Maybe a) -> a fromMaybesR a = fromMaybe a . fold (flip (<|>)) . (Nothing :>) --- | Returns 'Just a' when the boolean is 'True', or 'Nothing' when 'False'. --- --- * Examples: --- --- >>> orNothing True 5 --- Just 5 --- --- >>> orNothing False "Hello" --- Nothing +{- | Returns 'Just a' when the boolean is 'True', or 'Nothing' when 'False'. + +* Examples: + + >>> orNothing True 5 + Just 5 + + >>> orNothing False "Hello" + Nothing +-} orNothing :: Bool -> a -> Maybe a orNothing True a = Just a orNothing False _ = Nothing diff --git a/bittide-extra/src/Bittide/Extra/Wishbone.hs b/bittide-extra/src/Bittide/Extra/Wishbone.hs index b45c1963a..11a6ac386 100644 --- a/bittide-extra/src/Bittide/Extra/Wishbone.hs +++ b/bittide-extra/src/Bittide/Extra/Wishbone.hs @@ -5,8 +5,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} --- | --- See: http://cdn.opencores.org/downloads/wbspec_b4.pdf +{- | +See: http://cdn.opencores.org/downloads/wbspec_b4.pdf +-} module Bittide.Extra.Wishbone where import Clash.Prelude @@ -15,52 +16,60 @@ import Clash.Signal.Internal import Protocols import Protocols.Wishbone -import qualified Data.IntMap as I +import qualified Data.IntMap as I type DWord = BitVector (4 * 8) --- | The wishbone storage is a simulation only memory element that communicates via the --- Wishbone protocol : http://cdn.opencores.org/downloads/wbspec_b4.pdf . --- It receives a name for error identification, an Intmap of BitVector 8 as initial content. --- The storage is byte addressable. -wishboneStorage - :: String - -> I.IntMap (BitVector 8) - -> Circuit (Wishbone dom 'Standard 32 DWord) () +{- | The wishbone storage is a simulation only memory element that communicates via the +Wishbone protocol : http://cdn.opencores.org/downloads/wbspec_b4.pdf . +It receives a name for error identification, an Intmap of BitVector 8 as initial content. +The storage is byte addressable. +-} +wishboneStorage :: + String -> + I.IntMap (BitVector 8) -> + Circuit (Wishbone dom 'Standard 32 DWord) () wishboneStorage name initial = Circuit $ \(input, ()) -> (wishboneStorage' name state input, ()) where state = (initial, False) -wishboneStorage' - :: String - -> (I.IntMap (BitVector 8), Bool) - -> Signal dom (WishboneM2S 32 (BitSize DWord `DivRU` 8) DWord) - -> Signal dom (WishboneS2M DWord) +wishboneStorage' :: + String -> + (I.IntMap (BitVector 8), Bool) -> + Signal dom (WishboneM2S 32 (BitSize DWord `DivRU` 8) DWord) -> + Signal dom (WishboneS2M DWord) wishboneStorage' name state inputs = dataOut :- (wishboneStorage' name state' inputs') where input :- inputs' = inputs state' = (file', ack') (file, ack) = state - WishboneM2S{ addr - , writeData - , busSelect - , busCycle - , strobe - , writeEnable - } = input - file' | writeEnable = I.fromList assocList <> file - | otherwise = file + WishboneM2S + { addr + , writeData + , busSelect + , busCycle + , strobe + , writeEnable + } = input + file' + | writeEnable = I.fromList assocList <> file + | otherwise = file ack' = busCycle && strobe address = fromIntegral (unpack $ addr :: Unsigned 32) - readData = if not writeEnable - then - (file `lookup'` (address+3)) ++# - (file `lookup'` (address+2)) ++# - (file `lookup'` (address+1)) ++# - (file `lookup'` address) - else 0 - lookup' x addr' = I.findWithDefault (error $ name <> ": Uninitialized Memory Address = " <> show addr') addr' x + readData = + if not writeEnable + then + (file `lookup'` (address + 3)) + ++# (file `lookup'` (address + 2)) + ++# (file `lookup'` (address + 1)) + ++# (file `lookup'` address) + else 0 + lookup' x addr' = + I.findWithDefault + (error $ name <> ": Uninitialized Memory Address = " <> show addr') + addr' + x assocList = case busSelect of $(bitPattern "0001") -> [byte0] $(bitPattern "0010") -> [byte1] @@ -68,27 +77,29 @@ wishboneStorage' name state inputs = dataOut :- (wishboneStorage' name state' in $(bitPattern "1000") -> [byte3] $(bitPattern "0011") -> half0 $(bitPattern "1100") -> half1 - _ -> word0 + _ -> word0 byte0 = (address, slice d7 d0 writeData) - byte1 = (address+1, slice d15 d8 writeData) - byte2 = (address+2, slice d23 d16 writeData) - byte3 = (address+3, slice d31 d24 writeData) + byte1 = (address + 1, slice d15 d8 writeData) + byte2 = (address + 2, slice d23 d16 writeData) + byte3 = (address + 3, slice d31 d24 writeData) half0 = [byte0, byte1] half1 = [byte2, byte3] - word0 = [byte0, byte1, byte2, byte3] - dataOut = (emptyWishboneS2M @DWord) - { readData = readData - , acknowledge = ack - , err = False - } + word0 = [byte0, byte1, byte2, byte3] + dataOut = + (emptyWishboneS2M @DWord) + { readData = readData + , acknowledge = ack + , err = False + } --- | Wrapper for the wishboneStorage that allows two ports to be connected. --- Port A can only be used for reading, port B can read and write to the te storage. --- Writing from port A is illegal and write attempts will set the err signal. -instructionStorage - :: String - -> I.IntMap (BitVector 8) - -> Circuit (Wishbone dom 'Standard 32 DWord, Wishbone dom 'Standard 32 DWord) () +{- | Wrapper for the wishboneStorage that allows two ports to be connected. +Port A can only be used for reading, port B can read and write to the te storage. +Writing from port A is illegal and write attempts will set the err signal. +-} +instructionStorage :: + String -> + I.IntMap (BitVector 8) -> + Circuit (Wishbone dom 'Standard 32 DWord, Wishbone dom 'Standard 32 DWord) () instructionStorage name initial = Circuit go where go ((aM2S, bM2S), ()) = ((aS2M, bS2M), ()) @@ -104,6 +115,6 @@ instructionStorage name initial = Circuit go aS2M = mux (not <$> bActive) (writeIsErr <$> storageOut <*> aWriting) (noAck <$> storageOut) bS2M = storageOut - noAck wb = wb {acknowledge = False, err = False} - noWrite wb = wb {writeEnable = False} - writeIsErr wb write = wb {err = err wb || write} + noAck wb = wb{acknowledge = False, err = False} + noWrite wb = wb{writeEnable = False} + writeIsErr wb write = wb{err = err wb || write} diff --git a/bittide-extra/src/Clash/Sized/Vector/Extra.hs b/bittide-extra/src/Clash/Sized/Vector/Extra.hs index 062e12d0a..bb2803a46 100644 --- a/bittide-extra/src/Clash/Sized/Vector/Extra.hs +++ b/bittide-extra/src/Clash/Sized/Vector/Extra.hs @@ -7,18 +7,20 @@ module Clash.Sized.Vector.Extra where import Clash.Explicit.Prelude import Data.Maybe (fromMaybe) --- | Finds first element in given vector matching the predicate. Returns --- 'Nothing' if no element satisfied the predicate. -find :: KnownNat n => (a -> Bool) -> Vec n a -> Maybe a +{- | Finds first element in given vector matching the predicate. Returns +'Nothing' if no element satisfied the predicate. +-} +find :: (KnownNat n) => (a -> Bool) -> Vec n a -> Maybe a find f = foldl (<|>) Nothing . map go where go a | f a = Just a | otherwise = Nothing --- | Finds first element in given vector matching the predicate. Returns a --- default element (the first argument) if no element satisfied the predicate. -findWithDefault :: KnownNat n => a -> (a -> Bool) -> Vec n a -> a +{- | Finds first element in given vector matching the predicate. Returns a +default element (the first argument) if no element satisfied the predicate. +-} +findWithDefault :: (KnownNat n) => a -> (a -> Bool) -> Vec n a -> a findWithDefault a f = fromMaybe a . find f -- XXX: We need a bunch of zip functions due to an unfortunate coinciding bugs: @@ -28,276 +30,3142 @@ findWithDefault a f = fromMaybe a . find f -- -- | Like 'zip', but for 8 vectors -zip8 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7) +zip8 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7) zip8 = zipWith8 (,,,,,,,) {-# INLINE zip8 #-} -- | Like 'zipWith', but for 8 vectors -zipWith8 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 +zipWith8 :: + (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 zipWith8 f a0s a1s a2s a3s a4s a5s a6s a7s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7) -> f a0 a1 a2 a3 a4 a5 a6 a7) a0s (zip7 a1s a2s a3s a4s a5s a6s a7s) + zipWith + (\a0 (a1, a2, a3, a4, a5, a6, a7) -> f a0 a1 a2 a3 a4 a5 a6 a7) + a0s + (zip7 a1s a2s a3s a4s a5s a6s a7s) {-# INLINE zipWith8 #-} -- | Like 'zip', but for 9 vectors -zip9 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8) +zip9 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8) zip9 = zipWith9 (,,,,,,,,) {-# INLINE zip9 #-} -- | Like 'zipWith', but for 9 vectors -zipWith9 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 +zipWith9 :: + (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 zipWith9 f a0s a1s a2s a3s a4s a5s a6s a7s a8s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8) a0s (zip8 a1s a2s a3s a4s a5s a6s a7s a8s) + zipWith + (\a0 (a1, a2, a3, a4, a5, a6, a7, a8) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8) + a0s + (zip8 a1s a2s a3s a4s a5s a6s a7s a8s) {-# INLINE zipWith9 #-} -- | Like 'zip', but for 10 vectors -zip10 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) +zip10 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) zip10 = zipWith10 (,,,,,,,,,) {-# INLINE zip10 #-} -- | Like 'zipWith', but for 10 vectors -zipWith10 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 +zipWith10 :: + (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 zipWith10 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) a0s (zip9 a1s a2s a3s a4s a5s a6s a7s a8s a9s) + zipWith + (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) + a0s + (zip9 a1s a2s a3s a4s a5s a6s a7s a8s a9s) {-# INLINE zipWith10 #-} -- | Like 'zip', but for 11 vectors -zip11 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) +zip11 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) zip11 = zipWith11 (,,,,,,,,,,) {-# INLINE zip11 #-} -- | Like 'zipWith', but for 11 vectors -zipWith11 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 +zipWith11 :: + (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 zipWith11 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) a0s (zip10 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s) + zipWith + (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + a0s + (zip10 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s) {-# INLINE zipWith11 #-} -- | Like 'zip', but for 12 vectors -zip12 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) +zip12 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) zip12 = zipWith12 (,,,,,,,,,,,) {-# INLINE zip12 #-} -- | Like 'zipWith', but for 12 vectors -zipWith12 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 +zipWith12 :: + (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 zipWith12 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) a0s (zip11 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 + ) + a0s + (zip11 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s) {-# INLINE zipWith12 #-} -- | Like 'zip', but for 13 vectors -zip13 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) +zip13 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) zip13 = zipWith13 (,,,,,,,,,,,,) {-# INLINE zip13 #-} -- | Like 'zipWith', but for 13 vectors -zipWith13 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 +zipWith13 :: + (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 zipWith13 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) a0s (zip12 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 + ) + a0s + (zip12 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s) {-# INLINE zipWith13 #-} -- | Like 'zip', but for 14 vectors -zip14 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) +zip14 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) zip14 = zipWith14 (,,,,,,,,,,,,,) {-# INLINE zip14 #-} -- | Like 'zipWith', but for 14 vectors -zipWith14 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 +zipWith14 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 zipWith14 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) a0s (zip13 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 + ) + a0s + (zip13 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s) {-# INLINE zipWith14 #-} -- | Like 'zip', but for 15 vectors -zip15 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) +zip15 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) zip15 = zipWith15 (,,,,,,,,,,,,,,) {-# INLINE zip15 #-} -- | Like 'zipWith', but for 15 vectors -zipWith15 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 +zipWith15 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 zipWith15 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) a0s (zip14 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 + ) + a0s + (zip14 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s) {-# INLINE zipWith15 #-} -- | Like 'zip', but for 16 vectors -zip16 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) +zip16 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) zip16 = zipWith16 (,,,,,,,,,,,,,,,) {-# INLINE zip16 #-} -- | Like 'zipWith', but for 16 vectors -zipWith16 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 +zipWith16 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 zipWith16 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) a0s (zip15 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 + ) + a0s + (zip15 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s) {-# INLINE zipWith16 #-} -- | Like 'zip', but for 17 vectors -zip17 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16) +zip17 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16) zip17 = zipWith17 (,,,,,,,,,,,,,,,,) {-# INLINE zip17 #-} -- | Like 'zipWith', but for 17 vectors -zipWith17 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 +zipWith17 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 zipWith17 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) a0s (zip16 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 + ) + a0s + (zip16 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s) {-# INLINE zipWith17 #-} -- | Like 'zip', but for 18 vectors -zip18 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17) +zip18 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17) zip18 = zipWith18 (,,,,,,,,,,,,,,,,,) {-# INLINE zip18 #-} -- | Like 'zipWith', but for 18 vectors -zipWith18 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 +zipWith18 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 zipWith18 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) a0s (zip17 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 + ) + a0s + (zip17 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s) {-# INLINE zipWith18 #-} -- | Like 'zip', but for 19 vectors -zip19 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18) +zip19 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec + n + (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18) zip19 = zipWith19 (,,,,,,,,,,,,,,,,,,) {-# INLINE zip19 #-} -- | Like 'zipWith', but for 19 vectors -zipWith19 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 +zipWith19 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 zipWith19 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) a0s (zip18 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 + ) + a0s + (zip18 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s) {-# INLINE zipWith19 #-} -- | Like 'zip', but for 20 vectors -zip20 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19) +zip20 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec + n + (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19) zip20 = zipWith20 (,,,,,,,,,,,,,,,,,,,) {-# INLINE zip20 #-} -- | Like 'zipWith', but for 20 vectors -zipWith20 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 +zipWith20 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 zipWith20 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) a0s (zip19 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s) + zipWith + ( \a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 + ) + a0s + ( zip19 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + ) {-# INLINE zipWith20 #-} -- | Like 'zip', but for 21 vectors -zip21 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20) +zip21 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + ) zip21 = zipWith21 (,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip21 #-} -- | Like 'zipWith', but for 21 vectors -zipWith21 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 +zipWith21 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 zipWith21 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) a0s (zip20 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + ) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + ) + a0s + ( zip20 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + ) {-# INLINE zipWith21 #-} -- | Like 'zip', but for 22 vectors -zip22 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21) +zip22 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + ) zip22 = zipWith22 (,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip22 #-} -- | Like 'zipWith', but for 22 vectors -zipWith22 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 +zipWith22 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 zipWith22 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21) a0s (zip21 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + ) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 + ) + a0s + ( zip21 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + ) {-# INLINE zipWith22 #-} -- | Like 'zip', but for 23 vectors -zip23 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22) +zip23 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + ) zip23 = zipWith23 (,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip23 #-} -- | Like 'zipWith', but for 23 vectors -zipWith23 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 +zipWith23 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 zipWith23 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22) a0s (zip22 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + ) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 + ) + a0s + ( zip22 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + ) {-# INLINE zipWith23 #-} -- | Like 'zip', but for 24 vectors -zip24 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23) +zip24 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + ) zip24 = zipWith24 (,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip24 #-} -- | Like 'zipWith', but for 24 vectors -zipWith24 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 +zipWith24 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 zipWith24 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23) a0s (zip23 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + ) -> + f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 + ) + a0s + ( zip23 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + ) {-# INLINE zipWith24 #-} -- | Like 'zip', but for 25 vectors -zip25 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24) +zip25 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + ) zip25 = zipWith25 (,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip25 #-} -- | Like 'zipWith', but for 25 vectors -zipWith25 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 +zipWith25 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 zipWith25 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24) a0s (zip24 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + ) + a0s + ( zip24 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + ) {-# INLINE zipWith25 #-} -- | Like 'zip', but for 26 vectors -zip26 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25) +zip26 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + ) zip26 = zipWith26 (,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip26 #-} -- | Like 'zipWith', but for 26 vectors -zipWith26 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 +zipWith26 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 zipWith26 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25) a0s (zip25 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + ) + a0s + ( zip25 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + ) {-# INLINE zipWith26 #-} -- | Like 'zip', but for 27 vectors -zip27 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26) +zip27 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + ) zip27 = zipWith27 (,,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip27 #-} -- | Like 'zipWith', but for 27 vectors -zipWith27 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26 -> a27) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 +zipWith27 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 -> + a27 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 zipWith27 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26) a0s (zip26 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + ) + a0s + ( zip26 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + a26s + ) {-# INLINE zipWith27 #-} -- | Like 'zip', but for 28 vectors -zip28 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27) +zip28 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + ) zip28 = zipWith28 (,,,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip28 #-} -- | Like 'zipWith', but for 28 vectors -zipWith28 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26 -> a27 -> a28) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 +zipWith28 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 -> + a27 -> + a28 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 zipWith28 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27) a0s (zip27 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + ) + a0s + ( zip27 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + a26s + a27s + ) {-# INLINE zipWith28 #-} -- | Like 'zip', but for 29 vectors -zip29 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28) +zip29 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + ) zip29 = zipWith29 (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip29 #-} -- | Like 'zipWith', but for 29 vectors -zipWith29 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26 -> a27 -> a28 -> a29) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 +zipWith29 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 -> + a27 -> + a28 -> + a29 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 zipWith29 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28) a0s (zip28 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + ) + a0s + ( zip28 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + a26s + a27s + a28s + ) {-# INLINE zipWith29 #-} -- | Like 'zip', but for 30 vectors -zip30 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29) +zip30 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + , a29 + ) zip30 = zipWith30 (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip30 #-} -- | Like 'zipWith', but for 30 vectors -zipWith30 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26 -> a27 -> a28 -> a29 -> a30) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 -> Vec n a30 +zipWith30 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 -> + a27 -> + a28 -> + a29 -> + a30 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 -> + Vec n a30 zipWith30 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s a29s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29) a0s (zip29 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s a29s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + , a29 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + ) + a0s + ( zip29 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + a26s + a27s + a28s + a29s + ) {-# INLINE zipWith30 #-} -- | Like 'zip', but for 31 vectors -zip31 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 -> Vec n a30 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, a30) +zip31 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 -> + Vec n a30 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + , a29 + , a30 + ) zip31 = zipWith31 (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip31 #-} -- | Like 'zipWith', but for 31 vectors -zipWith31 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26 -> a27 -> a28 -> a29 -> a30 -> a31) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 -> Vec n a30 -> Vec n a31 +zipWith31 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 -> + a27 -> + a28 -> + a29 -> + a30 -> + a31 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 -> + Vec n a30 -> + Vec n a31 zipWith31 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s a29s a30s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, a30) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30) a0s (zip30 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s a29s a30s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + , a29 + , a30 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + ) + a0s + ( zip30 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + a26s + a27s + a28s + a29s + a30s + ) {-# INLINE zipWith31 #-} -- | Like 'zip', but for 32 vectors -zip32 :: Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 -> Vec n a30 -> Vec n a31 -> Vec n (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, a30, a31) +zip32 :: + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 -> + Vec n a30 -> + Vec n a31 -> + Vec + n + ( a0 + , a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + , a29 + , a30 + , a31 + ) zip32 = zipWith32 (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) {-# INLINE zip32 #-} -- | Like 'zipWith', but for 32 vectors -zipWith32 :: (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> a13 -> a14 -> a15 -> a16 -> a17 -> a18 -> a19 -> a20 -> a21 -> a22 -> a23 -> a24 -> a25 -> a26 -> a27 -> a28 -> a29 -> a30 -> a31 -> a32) -> Vec n a0 -> Vec n a1 -> Vec n a2 -> Vec n a3 -> Vec n a4 -> Vec n a5 -> Vec n a6 -> Vec n a7 -> Vec n a8 -> Vec n a9 -> Vec n a10 -> Vec n a11 -> Vec n a12 -> Vec n a13 -> Vec n a14 -> Vec n a15 -> Vec n a16 -> Vec n a17 -> Vec n a18 -> Vec n a19 -> Vec n a20 -> Vec n a21 -> Vec n a22 -> Vec n a23 -> Vec n a24 -> Vec n a25 -> Vec n a26 -> Vec n a27 -> Vec n a28 -> Vec n a29 -> Vec n a30 -> Vec n a31 -> Vec n a32 +zipWith32 :: + ( a0 -> + a1 -> + a2 -> + a3 -> + a4 -> + a5 -> + a6 -> + a7 -> + a8 -> + a9 -> + a10 -> + a11 -> + a12 -> + a13 -> + a14 -> + a15 -> + a16 -> + a17 -> + a18 -> + a19 -> + a20 -> + a21 -> + a22 -> + a23 -> + a24 -> + a25 -> + a26 -> + a27 -> + a28 -> + a29 -> + a30 -> + a31 -> + a32 + ) -> + Vec n a0 -> + Vec n a1 -> + Vec n a2 -> + Vec n a3 -> + Vec n a4 -> + Vec n a5 -> + Vec n a6 -> + Vec n a7 -> + Vec n a8 -> + Vec n a9 -> + Vec n a10 -> + Vec n a11 -> + Vec n a12 -> + Vec n a13 -> + Vec n a14 -> + Vec n a15 -> + Vec n a16 -> + Vec n a17 -> + Vec n a18 -> + Vec n a19 -> + Vec n a20 -> + Vec n a21 -> + Vec n a22 -> + Vec n a23 -> + Vec n a24 -> + Vec n a25 -> + Vec n a26 -> + Vec n a27 -> + Vec n a28 -> + Vec n a29 -> + Vec n a30 -> + Vec n a31 -> + Vec n a32 zipWith32 f a0s a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s a29s a30s a31s = - zipWith (\a0 (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, a30, a31) -> f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31) a0s (zip31 a1s a2s a3s a4s a5s a6s a7s a8s a9s a10s a11s a12s a13s a14s a15s a16s a17s a18s a19s a20s a21s a22s a23s a24s a25s a26s a27s a28s a29s a30s a31s) + zipWith + ( \a0 + ( a1 + , a2 + , a3 + , a4 + , a5 + , a6 + , a7 + , a8 + , a9 + , a10 + , a11 + , a12 + , a13 + , a14 + , a15 + , a16 + , a17 + , a18 + , a19 + , a20 + , a21 + , a22 + , a23 + , a24 + , a25 + , a26 + , a27 + , a28 + , a29 + , a30 + , a31 + ) -> + f + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + ) + a0s + ( zip31 + a1s + a2s + a3s + a4s + a5s + a6s + a7s + a8s + a9s + a10s + a11s + a12s + a13s + a14s + a15s + a16s + a17s + a18s + a19s + a20s + a21s + a22s + a23s + a24s + a25s + a26s + a27s + a28s + a29s + a30s + a31s + ) {-# INLINE zipWith32 #-} diff --git a/bittide-extra/src/Numeric/Extra.hs b/bittide-extra/src/Numeric/Extra.hs index 34609e94e..6263dc1f4 100644 --- a/bittide-extra/src/Numeric/Extra.hs +++ b/bittide-extra/src/Numeric/Extra.hs @@ -9,20 +9,21 @@ import Clash.Prelude import Control.Monad (foldM) import Data.Char (digitToInt, isHexDigit) --- | Parse a hexadecimal string into a 'BitPack'able type. --- --- Note that this function does not handle types that do not use the full range --- of their bit size. For example, 'Index' will return an 'XException' if the --- parsed value is out of range of the @'Index' n@, but in range of --- @'BitVector' ('BitSize' ('Index' n))@. To fix this properly, we need a version --- of 'unpack' that returns a 'Maybe' value. -parseHex :: forall a. BitPack a => String -> Either String a +{- | Parse a hexadecimal string into a 'BitPack'able type. + +Note that this function does not handle types that do not use the full range +of their bit size. For example, 'Index' will return an 'XException' if the +parsed value is out of range of the @'Index' n@, but in range of +@'BitVector' ('BitSize' ('Index' n))@. To fix this properly, we need a version +of 'unpack' that returns a 'Maybe' value. +-} +parseHex :: forall a. (BitPack a) => String -> Either String a parseHex "" = Left "Empty string" parseHex s = do result <- foldM parseDigit (0 :: Integer) s - if result > natToNum @(2^BitSize a - 1) - then Left $ "Value is out of range: " <> show result - else Right $ unpack (fromInteger result) + if result > natToNum @(2 ^ BitSize a - 1) + then Left $ "Value is out of range: " <> show result + else Right $ unpack (fromInteger result) where parseDigit !a c | not (isHexDigit c) = Left $ "Non-hexadecimal digit: " <> [c] <> " in " <> s diff --git a/bittide-extra/tests/doctests/Main.hs b/bittide-extra/tests/doctests/Main.hs index f404abb9f..c3cfcfa01 100644 --- a/bittide-extra/tests/doctests/Main.hs +++ b/bittide-extra/tests/doctests/Main.hs @@ -11,4 +11,4 @@ main :: IO () main = do -- We use Nix to setup tooling, not to provide GHC packages so we need to set --no-nix args <- getArgs - mainFromCabal "bittide-extra" ("--no-nix":args) + mainFromCabal "bittide-extra" ("--no-nix" : args) diff --git a/bittide-extra/tests/unittests/Main.hs b/bittide-extra/tests/unittests/Main.hs index 003a72ad8..7a7f038bc 100644 --- a/bittide-extra/tests/unittests/Main.hs +++ b/bittide-extra/tests/unittests/Main.hs @@ -8,19 +8,23 @@ import Prelude import Test.Tasty +import Test.Tasty.Hedgehog (HedgehogTestLimit (..)) import qualified Tests.Numeric.Extra -import Test.Tasty.Hedgehog (HedgehogTestLimit(..)) setDefaultHedgehogTestLimit :: HedgehogTestLimit -> HedgehogTestLimit setDefaultHedgehogTestLimit (HedgehogTestLimit Nothing) = HedgehogTestLimit (Just 10000) setDefaultHedgehogTestLimit opt = opt tests :: TestTree -tests = testGroup "tests" - [ Tests.Numeric.Extra.tests - ] +tests = + testGroup + "tests" + [ Tests.Numeric.Extra.tests + ] main :: IO () -main = defaultMain $ - adjustOption setDefaultHedgehogTestLimit - tests +main = + defaultMain $ + adjustOption + setDefaultHedgehogTestLimit + tests diff --git a/bittide-extra/tests/unittests/Tests/Numeric/Extra.hs b/bittide-extra/tests/unittests/Tests/Numeric/Extra.hs index 96141c210..09705af65 100644 --- a/bittide-extra/tests/unittests/Tests/Numeric/Extra.hs +++ b/bittide-extra/tests/unittests/Tests/Numeric/Extra.hs @@ -16,12 +16,13 @@ import Numeric.Extra (parseHex) import Test.Tasty import Test.Tasty.Hedgehog -import qualified Hedgehog.Range as Range -import qualified Hedgehog.Internal.Gen as Gen import Data.Proxy +import qualified Hedgehog.Internal.Gen as Gen +import qualified Hedgehog.Range as Range --- | Generate an in range value, convert it to hex, and parse it back. The result --- should be the same as the original value. +{- | Generate an in range value, convert it to hex, and parse it back. The result +should be the same as the original value. +-} parseHexInRange :: forall a m. (Monad m, BitPack a, Eq a, Show a, Bounded a, Integral a) => @@ -41,8 +42,9 @@ parseHexInRangeUnsigned = property $ do SomeNat (Proxy :: Proxy n) -> parseHexInRange (genUnsigned @_ @n Range.constantBounded) --- | Generate an in range value, add @maxBound + 1@ to it, convert it to hex, and --- parse it back. The result should yield a parse error. +{- | Generate an in range value, add @maxBound + 1@ to it, convert it to hex, and +parse it back. The result should yield a parse error. +-} parseHexOutOfRange :: forall a m. (Monad m, BitPack a, Eq a, Show a, Bounded a, Integral a, Typeable a) => @@ -72,11 +74,18 @@ parseHexOutOfRangeUnsigned = property $ do parseHexOutOfRange (genUnsigned @_ @n Range.constantBounded) tests :: TestTree -tests = testGroup "Tests.Numeric.Extra" - [ testGroup "parseHexRountTrip" - [ testPropertyNamed - "Unsigned in range" "parseHexInRangeUnsigned" parseHexInRangeUnsigned - , testPropertyNamed - "Unsigned out of range" "parseHexOutOfRangeUnsigned" parseHexOutOfRangeUnsigned +tests = + testGroup + "Tests.Numeric.Extra" + [ testGroup + "parseHexRountTrip" + [ testPropertyNamed + "Unsigned in range" + "parseHexInRangeUnsigned" + parseHexInRangeUnsigned + , testPropertyNamed + "Unsigned out of range" + "parseHexOutOfRangeUnsigned" + parseHexOutOfRangeUnsigned + ] ] - ] diff --git a/bittide-instances/exe/clash/Main.hs b/bittide-instances/exe/clash/Main.hs index f945253e0..95c2721f2 100644 --- a/bittide-instances/exe/clash/Main.hs +++ b/bittide-instances/exe/clash/Main.hs @@ -2,9 +2,9 @@ -- -- SPDX-License-Identifier: Apache-2.0 -import Prelude -import System.Environment (getArgs) import Clash.Main (defaultMain) +import System.Environment (getArgs) +import Prelude main :: IO () main = defaultMain =<< getArgs diff --git a/bittide-instances/exe/post-board-test-extended/Main.hs b/bittide-instances/exe/post-board-test-extended/Main.hs index c26180702..31d829399 100644 --- a/bittide-instances/exe/post-board-test-extended/Main.hs +++ b/bittide-instances/exe/post-board-test-extended/Main.hs @@ -9,20 +9,24 @@ import System.Environment (getArgs) import System.FilePath (()) import System.FilePath.Glob (glob) -import Bittide.Instances.Hitl.Post.PostProcess import Bittide.Instances.Hitl.Post.BoardTestExtended - +import Bittide.Instances.Hitl.Post.PostProcess main :: IO () main = do args <- getArgs case args of - ilaDir : [testExitCode] -> do + ilaDir : [testExitCode] -> do csvPaths <- glob (ilaDir "*" "*" "*.csv") let ilaCsvPaths = toFlattenedIlaCsvPathList ilaDir csvPaths let exitCode = read testExitCode postBoardTestExtended exitCode ilaCsvPaths - - [] -> throwIO (userError "Expected 2 arguments (ILA data dir and HITL test exit code), got none") - _ -> throwIO (userError $ "Expected 2 arguments (ILA data dir and HITL test exit code), got: " <> unwords args) + [] -> + throwIO + (userError "Expected 2 arguments (ILA data dir and HITL test exit code), got none") + _ -> + throwIO + ( userError $ + "Expected 2 arguments (ILA data dir and HITL test exit code), got: " <> unwords args + ) pure () diff --git a/bittide-instances/exe/post-fullMeshSwCcTest/Main.hs b/bittide-instances/exe/post-fullMeshSwCcTest/Main.hs index 7ce9193a7..64c0803ee 100644 --- a/bittide-instances/exe/post-fullMeshSwCcTest/Main.hs +++ b/bittide-instances/exe/post-fullMeshSwCcTest/Main.hs @@ -1,35 +1,36 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TupleSections #-} --- | This program extracts the UGNs from the last sample of the ila dumps of the fullMeshSwCcTest, --- And combines them from both sides of each link to calculate the IGNs. +{- | This program extracts the UGNs from the last sample of the ila dumps of the fullMeshSwCcTest, +And combines them from both sides of each link to calculate the IGNs. +-} module Main where -import Prelude + import qualified Clash.Prelude as C +import Prelude -import Control.Monad (forM, forM_,filterM, join) import Control.DeepSeq (deepseq) +import Control.Monad (filterM, forM, forM_, join) import qualified Data.ByteString.Lazy as ByteString import Data.Csv import Data.Int (Int64) -import Data.List (intercalate,sort) +import Data.List (intercalate, sort) import Data.Maybe (catMaybes) import qualified Data.Vector as Vector -import System.Directory (listDirectory, doesDirectoryExist) +import System.Directory (doesDirectoryExist, listDirectory) import System.Environment (getArgs) -import System.Exit (ExitCode(..)) +import System.Exit (ExitCode (..)) import System.FilePath (()) -import System.IO (stderr, hPutStrLn, IOMode (WriteMode), hPutStr, withFile) +import System.IO (IOMode (WriteMode), hPutStr, hPutStrLn, stderr, withFile) import Text.Read (readMaybe) import Bittide.Instances.Hitl.Setup (fpgaSetup) - type FpgaNo = Int type FpgaId = String type TestNo = Int @@ -43,7 +44,8 @@ data Ugns a = Ugns , probe_ugn4 :: a , probe_ugn5 :: a , probe_ugn6 :: a - } deriving (Show, Functor) + } + deriving (Show, Functor) ugnsToList :: Ugns a -> [a] ugnsToList ugns = @@ -56,21 +58,22 @@ ugnsToList ugns = , probe_ugn6 ugns ] -instance FromField a => FromNamedRecord (Ugns a) where - parseNamedRecord m = Ugns - <$> m .: "probe_ugn0" - <*> m .: "probe_ugn1" - <*> m .: "probe_ugn2" - <*> m .: "probe_ugn3" - <*> m .: "probe_ugn4" - <*> m .: "probe_ugn5" - <*> m .: "probe_ugn6" +instance (FromField a) => FromNamedRecord (Ugns a) where + parseNamedRecord m = + Ugns + <$> m .: "probe_ugn0" + <*> m .: "probe_ugn1" + <*> m .: "probe_ugn2" + <*> m .: "probe_ugn3" + <*> m .: "probe_ugn4" + <*> m .: "probe_ugn5" + <*> m .: "probe_ugn6" fpgaIds :: [FpgaId] fpgaIds = C.toList $ fmap fst fpgaSetup -fpgas :: [(FpgaNo,FpgaId)] -fpgas = zip [(0::FpgaNo)..] fpgaIds +fpgas :: [(FpgaNo, FpgaId)] +fpgas = zip [(0 :: FpgaNo) ..] fpgaIds fpgaLinks :: [[Int]] fpgaLinks = C.toList $ fmap (C.toList . fmap fromIntegral . snd) fpgaSetup @@ -79,45 +82,46 @@ main :: IO () main = do args <- getArgs case args of - [ilaDir,exitCode0] -> case readMaybe @ExitCode exitCode0 of + [ilaDir, exitCode0] -> case readMaybe @ExitCode exitCode0 of Nothing -> error $ "Couldn't parse second argument (" <> show exitCode0 <> ") as ExitCode" - Just exitCode | exitCode /= ExitSuccess -> error $ "Test run failed, got exit code " <> show exitCode - | otherwise -> doIt ilaDir + Just exitCode + | exitCode /= ExitSuccess -> error $ "Test run failed, got exit code " <> show exitCode + | otherwise -> doIt ilaDir ilaDir : _ -> doIt ilaDir [] -> error "I need the path to the ila-data" -- | Parses "CCn" to Just n, otherwise Nothing parseCCnum :: String -> Maybe TestNo parseCCnum str = case splitAt 2 str of - ("CC",n) -> readMaybe n + ("CC", n) -> readMaybe n _ -> Nothing doIt :: FilePath -> IO () doIt ilaDir = do - dirs :: [FilePath] <- join $ (filterM (\d -> doesDirectoryExist (ilaDir d))) <$> listDirectory ilaDir + dirs :: [FilePath] <- + join $ (filterM (\d -> doesDirectoryExist (ilaDir d))) <$> listDirectory ilaDir let testNos = sort $ catMaybes $ map parseCCnum dirs tests :: [[[Int64]]] <- forM testNos $ \testNo -> - forM fpgas $ \(fpgaNo,fpgaId) -> do - let filename = ilaDir "CC" ++ show testNo show fpgaNo ++ "_" ++ fpgaId "fincFdecIla.csv" + forM fpgas $ \(fpgaNo, fpgaId) -> do + let filename = ilaDir "CC" ++ show testNo show fpgaNo ++ "_" ++ fpgaId "fincFdecIla.csv" hPutStrLn stderr $ "Reading " <> filename Right (_, csv0) <- decodeByName @(Ugns String) <$> ByteString.readFile filename - let results = ugnsToList $ read @Int64 . ("0x"<>) <$> Vector.last csv0 + let results = ugnsToList $ read @Int64 . ("0x" <>) <$> Vector.last csv0 results `deepseq` pure results ugns <- forM tests $ \test -> do - forM (zip [(0::FpgaNo)..] test) $ \(fpgano, ugns) -> do + forM (zip [(0 :: FpgaNo) ..] test) $ \(fpgano, ugns) -> do fmap (fpgano,) $ - forM (zip [(0::LinkNo)..] ugns) $ \(linkno, ugn) -> do + forM (zip [(0 :: LinkNo) ..] ugns) $ \(linkno, ugn) -> do let otherUgn = test !! (fpgaLinks !! fpgano !! linkno) !! linkno pure (linkno, ugn, ugn + otherUgn) - - forM_ fpgas $ \(fpgaNo,_) -> do + forM_ fpgas $ \(fpgaNo, _) -> do withFile (ilaDir "results_fpga_" <> show fpgaNo <> ".csv") WriteMode $ \h -> do - let ugns1 = (!!fpgaNo) <$> ugns + let ugns1 = (!! fpgaNo) <$> ugns hPutStr h "testno," - y <- forM [(0::LinkNo)..6] $ \linkNo -> + y <- forM [(0 :: LinkNo) .. 6] $ \linkNo -> pure $ "ugn" <> show linkNo <> "," <> "ign" <> show linkNo hPutStrLn h (intercalate "," y) diff --git a/bittide-instances/exe/post-vex-riscv-test/Main.hs b/bittide-instances/exe/post-vex-riscv-test/Main.hs index f38ec8bbc..a6a78051d 100644 --- a/bittide-instances/exe/post-vex-riscv-test/Main.hs +++ b/bittide-instances/exe/post-vex-riscv-test/Main.hs @@ -8,7 +8,7 @@ import Paths_bittide_instances import Control.Monad (unless) import Control.Monad.Extra (forM_) -import Data.List.Extra (trim, isPrefixOf) +import Data.List.Extra (isPrefixOf, trim) import Data.Maybe (fromJust) import System.Environment (withArgs) import System.IO @@ -30,15 +30,17 @@ getPicocomStartPath = getDataFileName "data/picocom/start.sh" getGdbProgPath :: IO FilePath getGdbProgPath = getDataFileName "data/gdb/test-gdb-prog" --- | XXX: Currently hardcoded to a very specific position. Maybe we could probe --- using JTAG to see what device we're connected to? +{- | 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. +{- | 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 :: (String -> IO ()) -> IO () withAnnotatedGdbProgPath action = do srcPath <- getGdbProgPath @@ -49,56 +51,59 @@ withAnnotatedGdbProgPath action = do let trimmedLine = trim line unless (null trimmedLine || "#" `isPrefixOf` trimmedLine) - ( hPutStr dstHandle "echo > " - >> hPutStr dstHandle line - >> hPutStrLn dstHandle "\\n" ) + ( 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) -> Assertion +{- | 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) -> Assertion 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'). + 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 + 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. --- +{- | 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 @@ -107,9 +112,9 @@ case_testGdbProgram = do withAnnotatedGdbProgPath $ \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} + 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 diff --git a/bittide-instances/src/Bittide/Instances/Domains.hs b/bittide-instances/src/Bittide/Instances/Domains.hs index a2f84ff9e..cdcd552fe 100644 --- a/bittide-instances/src/Bittide/Instances/Domains.hs +++ b/bittide-instances/src/Bittide/Instances/Domains.hs @@ -8,67 +8,73 @@ module Bittide.Instances.Domains where import Clash.Explicit.Prelude hiding (PeriodToCycles) -import Bittide.ClockControl -import Bittide.Arithmetic.Time import Bittide.Arithmetic.Ppm +import Bittide.Arithmetic.Time +import Bittide.ClockControl import Data.Proxy -createDomain vXilinxSystem{vName="Basic100", vPeriod= hzToPeriod 100e6} -createDomain vXilinxSystem{vName="Basic125", vPeriod= hzToPeriod 125e6} -createDomain vXilinxSystem{vName="Basic125A", vPeriod= hzToPeriod 125e6} -createDomain vXilinxSystem{vName="Basic125B", vPeriod= hzToPeriod 125e6} -createDomain vXilinxSystem{vName="Basic199", vPeriod=hzToPeriod 199e6} -createDomain vXilinxSystem{vName="Basic200", vPeriod=hzToPeriod 200e6} -createDomain vXilinxSystem{vName="Basic25", vPeriod= hzToPeriod 25e6} -createDomain vXilinxSystem{vName="Basic300", vPeriod=hzToPeriod 300e6} -createDomain vXilinxSystem{vName="Basic50", vPeriod= hzToPeriod 50e6} -createDomain vXilinxSystem{vName="Basic625", vPeriod=hzToPeriod 625e6, vResetKind=Asynchronous} -createDomain vXilinxSystem{vName="Ext125", vPeriod= hzToPeriod 125e6, vResetKind=Asynchronous} -createDomain vXilinxSystem{vName="Ext200", vPeriod=hzToPeriod 200e6, vResetKind=Asynchronous} -createDomain vXilinxSystem{vName="Ext200A", vPeriod=hzToPeriod 200e6} -createDomain vXilinxSystem{vName="Ext200B", vPeriod=hzToPeriod 200e6} -createDomain vXilinxSystem{vName="Ext300", vPeriod=hzToPeriod 300e6, vResetKind=Asynchronous} -createDomain vXilinxSystem{vName="External", vPeriod=hzToPeriod 200e6} -createDomain vXilinxSystem{vName="GthRx", vPeriod=hzToPeriod 125e6} -createDomain vXilinxSystem{vName="GthTx", vPeriod= hzToPeriod 125e6} -createDomain vXilinxSystem{vName="GthRxS", vPeriod=hzToPeriod 10e9} -createDomain vXilinxSystem{vName="GthTxS", vPeriod= hzToPeriod 10e9} -createDomain vXilinxSystem{vName="Internal", vPeriod=hzToPeriod 200e6} +createDomain vXilinxSystem{vName = "Basic100", vPeriod = hzToPeriod 100e6} +createDomain vXilinxSystem{vName = "Basic125", vPeriod = hzToPeriod 125e6} +createDomain vXilinxSystem{vName = "Basic125A", vPeriod = hzToPeriod 125e6} +createDomain vXilinxSystem{vName = "Basic125B", vPeriod = hzToPeriod 125e6} +createDomain vXilinxSystem{vName = "Basic199", vPeriod = hzToPeriod 199e6} +createDomain vXilinxSystem{vName = "Basic200", vPeriod = hzToPeriod 200e6} +createDomain vXilinxSystem{vName = "Basic25", vPeriod = hzToPeriod 25e6} +createDomain vXilinxSystem{vName = "Basic300", vPeriod = hzToPeriod 300e6} +createDomain vXilinxSystem{vName = "Basic50", vPeriod = hzToPeriod 50e6} +createDomain + vXilinxSystem{vName = "Basic625", vPeriod = hzToPeriod 625e6, vResetKind = Asynchronous} +createDomain + vXilinxSystem{vName = "Ext125", vPeriod = hzToPeriod 125e6, vResetKind = Asynchronous} +createDomain + vXilinxSystem{vName = "Ext200", vPeriod = hzToPeriod 200e6, vResetKind = Asynchronous} +createDomain vXilinxSystem{vName = "Ext200A", vPeriod = hzToPeriod 200e6} +createDomain vXilinxSystem{vName = "Ext200B", vPeriod = hzToPeriod 200e6} +createDomain + vXilinxSystem{vName = "Ext300", vPeriod = hzToPeriod 300e6, vResetKind = Asynchronous} +createDomain vXilinxSystem{vName = "External", vPeriod = hzToPeriod 200e6} +createDomain vXilinxSystem{vName = "GthRx", vPeriod = hzToPeriod 125e6} +createDomain vXilinxSystem{vName = "GthTx", vPeriod = hzToPeriod 125e6} +createDomain vXilinxSystem{vName = "GthRxS", vPeriod = hzToPeriod 10e9} +createDomain vXilinxSystem{vName = "GthTxS", vPeriod = hzToPeriod 10e9} +createDomain vXilinxSystem{vName = "Internal", vPeriod = hzToPeriod 200e6} type CccBufferSize = 25 :: Nat type CccStabilityCheckerMargin = 25 :: Nat type CccStabilityCheckerFramesize dom = PeriodToCycles dom (Seconds 2) type CccReframingWaitTime dom = PeriodToCycles dom (Seconds 5) --- | Clock configuration used for instances. --- --- Compared to 'defClockConfig' this configuration has an increased --- buffer size ('CccBufferSize'), disables reframing and uses more "human" --- values for framesize and wait time. +{- | Clock configuration used for instances. + +Compared to 'defClockConfig' this configuration has an increased +buffer size ('CccBufferSize'), disables reframing and uses more "human" +values for framesize and wait time. +-} instancesClockConfig :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => Proxy dom -> ClockControlConfig dom CccBufferSize CccStabilityCheckerMargin (CccStabilityCheckerFramesize dom) -instancesClockConfig Proxy = ClockControlConfig - { cccPessimisticPeriod = pessimisticPeriod - , cccPessimisticSettleCycles = pessimisticSettleCycles self - , cccSettlePeriod = microseconds 1 - , cccStepSize = stepSize - , cccBufferSize = SNat - , cccDeviation = Ppm 100 - , cccStabilityCheckerMargin = SNat - , cccStabilityCheckerFramesize = SNat - , cccEnableReframing = False - -- changed from defClockConfig, which uses a fixed number of cycles independent - -- the clock speed of the domain - , cccReframingWaitTime = natToNum @(PeriodToCycles dom (Seconds 1)) - , cccEnableRustySimulation = False - } +instancesClockConfig Proxy = + ClockControlConfig + { cccPessimisticPeriod = pessimisticPeriod + , cccPessimisticSettleCycles = pessimisticSettleCycles self + , cccSettlePeriod = microseconds 1 + , cccStepSize = stepSize + , cccBufferSize = SNat + , cccDeviation = Ppm 100 + , cccStabilityCheckerMargin = SNat + , cccStabilityCheckerFramesize = SNat + , cccEnableReframing = False + , -- changed from defClockConfig, which uses a fixed number of cycles independent + -- the clock speed of the domain + cccReframingWaitTime = natToNum @(PeriodToCycles dom (Seconds 1)) + , cccEnableRustySimulation = False + } where self = instancesClockConfig (Proxy @dom) stepSize = diffPeriod (Ppm 1) (clockPeriodFs @dom Proxy) diff --git a/bittide-instances/src/Bittide/Instances/Hacks.hs b/bittide-instances/src/Bittide/Instances/Hacks.hs index 63d051734..6d07d2d23 100644 --- a/bittide-instances/src/Bittide/Instances/Hacks.hs +++ b/bittide-instances/src/Bittide/Instances/Hacks.hs @@ -7,24 +7,24 @@ module Bittide.Instances.Hacks where -import Clash.Prelude import qualified Clash.Explicit.Prelude as E +import Clash.Prelude --- | Chaotically distributes a single incoming bit to input bits of the given --- function. Similarly, it chaotically reduces the all output bits of a function --- into a single bit. Both the input and output of the function will be directly --- connected to a register after applying 'reducePins'. --- --- This function is useful for synthesis analysis: although it feeds the circuit --- with garbage values, it only needs one input and one output pin. Because all --- the in and output pins of the circuit under test are directly connected to --- a register, synthesis timing results will (somewhat) realistically reflect --- timing capabilities. --- --- See 'reducePins' for a 'BitPack' version of this function. --- +{- | Chaotically distributes a single incoming bit to input bits of the given +function. Similarly, it chaotically reduces the all output bits of a function +into a single bit. Both the input and output of the function will be directly +connected to a register after applying 'reducePins'. + +This function is useful for synthesis analysis: although it feeds the circuit +with garbage values, it only needs one input and one output pin. Because all +the in and output pins of the circuit under test are directly connected to +a register, synthesis timing results will (somewhat) realistically reflect +timing capabilities. + +See 'reducePins' for a 'BitPack' version of this function. +-} reducePins# :: - forall dom m n . + forall dom m n. (HiddenClock dom, KnownNat m, KnownNat n) => (Signal dom (BitVector m) -> Signal dom (BitVector n)) -> Signal dom Bit -> @@ -41,7 +41,7 @@ reducePins# f pin = out -- try to do. -- shiftRegIn = liftA2 (.<<+) shiftReg (xor <$> pin <*> out) - shiftReg = E.delay @dom @(BitVector (m+n)) clk ena 0 shiftRegIn + shiftReg = E.delay @dom @(BitVector (m + n)) clk ena 0 shiftRegIn out = go <$> outs <*> E.delay clk ena 0 (f ins) (ins, outs) = unbundle (split @_ @m @n <$> shiftReg) go a b = reduceXor (a `xor` b) @@ -49,19 +49,19 @@ reducePins# f pin = out clk = hasClock ena = enableGen --- | Chaotically distributes a single incoming bit to input bits of the given --- function. Similarly, it chaotically reduces the all output bits of a function --- into a single bit. Both the input and output of the function will be directly --- connected to a register after applying 'reducePins'. --- --- This function is useful for synthesis analysis: although it feeds the circuit --- with garbage values, it only needs one input and one output pin. Because all --- the in and output pins of the circuit under test are directly connected to --- a register, synthesis timing results will (somewhat) realistically reflect --- timing capabilities. --- +{- | Chaotically distributes a single incoming bit to input bits of the given +function. Similarly, it chaotically reduces the all output bits of a function +into a single bit. Both the input and output of the function will be directly +connected to a register after applying 'reducePins'. + +This function is useful for synthesis analysis: although it feeds the circuit +with garbage values, it only needs one input and one output pin. Because all +the in and output pins of the circuit under test are directly connected to +a register, synthesis timing results will (somewhat) realistically reflect +timing capabilities. +-} reducePins :: - forall dom a b . + forall dom a b. (HiddenClock dom, BitPack a, BitPack b) => (Signal dom a -> Signal dom b) -> Signal dom Bit -> @@ -70,7 +70,7 @@ reducePins f = reducePins# (fmap pack . f . fmap unpack) -- | Bundled version of 'reducePins'. reducePinsB :: - forall dom a b . + forall dom a b. (HiddenClock dom, Bundle a, BitPack a, BitPack b, Bundle b) => (Unbundled dom a -> Unbundled dom b) -> Signal dom Bit -> diff --git a/bittide-instances/src/Bittide/Instances/Hitl/BoardTest.hs b/bittide-instances/src/Bittide/Instances/Hitl/BoardTest.hs index 39c2b5521..5bd853b49 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/BoardTest.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/BoardTest.hs @@ -3,18 +3,26 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE OverloadedStrings #-} --- | Checks whether `+` and `-` work as expected, though its real purpose is to --- check whether we can run hardware-in-the-loop tests. +{- | Checks whether `+` and `-` work as expected, though its real purpose is to +check whether we can run hardware-in-the-loop tests. +-} module Bittide.Instances.Hitl.BoardTest where import Clash.Explicit.Prelude import Clash.Annotations.TH (makeTopEntity) -import Clash.Cores.Xilinx.Ila import Clash.Cores.Xilinx.Extra (ibufds) +import Clash.Cores.Xilinx.Ila +import Bittide.Hitl ( + HitlTests, + allFpgas, + hitlVio, + hitlVioBool, + noConfigTest, + testsFromEnum, + ) import Bittide.Instances.Domains -import Bittide.Hitl (HitlTests, allFpgas, testsFromEnum, hitlVioBool, hitlVio, noConfigTest) type TestStart = Bool data TestState = Busy | Done TestSuccess @@ -32,7 +40,7 @@ data CheckState n deriving (Generic, NFDataX) check :: - forall n a b c dom . + forall n a b c dom. ( KnownDomain dom , KnownNat n , Eq c @@ -51,18 +59,22 @@ check clk rst dut stimuli = where (a, b, c) = stimuli !! n testResult = dut a b == c - s | not testResult = CsDone TestFailed + s + | not testResult = CsDone TestFailed | n == maxBound = CsDone TestSuccess | otherwise = CsChecking (n + 1) --- | Testing circuit for `plus`. Feeds the circuit with inputs and checks --- the received output against the expected output. +{- | Testing circuit for `plus`. Feeds the circuit with inputs and checks +the received output against the expected output. +-} boardTestSimple :: "CLK_125MHZ" ::: DiffClock Ext125 -> - "" ::: Signal Ext125 - ( "done" ::: Bool - , "success" ::: Bool - ) + "" + ::: Signal + Ext125 + ( "done" ::: Bool + , "success" ::: Bool + ) boardTestSimple diffClk = bundle (testDone, testSuccess) where clk = ibufds diffClk @@ -74,23 +86,27 @@ boardTestSimple diffClk = bundle (testDone, testSuccess) testStart = hitlVioBool clk testDone testSuccess stimuli :: Vec 4 (Unsigned 8, Unsigned 8, Unsigned 8) - stimuli = ( - ( 0, 0, 0) - :> ( 1, 2, 3) - :> (255, 0, 255) - :> (255, 1, 0) - :> Nil + stimuli = + ( (0, 0, 0) + :> (1, 2, 3) + :> (255, 0, 255) + :> (255, 1, 0) + :> Nil ) + makeTopEntity 'boardTestSimple --- | Testing circuit for `plus` and `minus`. Feeds the circuit with inputs and --- checks the received output against the expected output. +{- | Testing circuit for `plus` and `minus`. Feeds the circuit with inputs and +checks the received output against the expected output. +-} boardTestExtended :: "CLK_125MHZ" ::: DiffClock Ext125 -> - "" ::: Signal Ext125 - ( "done" ::: Bool - , "success" ::: Bool - ) + "" + ::: Signal + Ext125 + ( "done" ::: Bool + , "success" ::: Bool + ) boardTestExtended diffClk = hwSeqX boardTestIla $ bundle (testDone, testSuccess) where clk = ibufds diffClk @@ -110,46 +126,45 @@ boardTestExtended diffClk = hwSeqX boardTestIla $ bundle (testDone, testSuccess) boardTestIla :: Signal Ext125 () boardTestIla = - setName @"boardTestIla" $ - ila - (ilaConfig $ - "trigger_AorB" - :> "capture" - :> "ilaTestStartA" - :> "ilaTestStartB" - :> "ilaTestDone" - :> "ilaTestSuccess" - :> Nil - ) - clk - -- Trigger when starting either test - (testStartA .||. testStartB) - -- Always capture - (pure True :: Signal Ext125 Bool) - - -- Debug probes - testStartA - testStartB - testDone - testSuccess - + setName @"boardTestIla" + $ ila + ( ilaConfig + $ "trigger_AorB" + :> "capture" + :> "ilaTestStartA" + :> "ilaTestStartB" + :> "ilaTestDone" + :> "ilaTestSuccess" + :> Nil + ) + clk + -- Trigger when starting either test + (testStartA .||. testStartB) + -- Always capture + (pure True :: Signal Ext125 Bool) + -- Debug probes + testStartA + testStartB + testDone + testSuccess stimuliA :: Vec 4 (Unsigned 8, Unsigned 8, Unsigned 8) - stimuliA = ( - ( 0, 0, 0) - :> ( 1, 2, 3) - :> (255, 0, 255) - :> (255, 1, 0) - :> Nil + stimuliA = + ( (0, 0, 0) + :> (1, 2, 3) + :> (255, 0, 255) + :> (255, 1, 0) + :> Nil ) stimuliB :: Vec 4 (Unsigned 8, Unsigned 8, Unsigned 8) - stimuliB = ( - ( 0, 0, 0) - :> ( 3, 2, 1) - :> (255, 0, 255) - :> ( 0, 1, 255) - :> Nil + stimuliB = + ( (0, 0, 0) + :> (3, 2, 1) + :> (255, 0, 255) + :> (0, 1, 255) + :> Nil ) + makeTopEntity 'boardTestExtended testsSimple :: HitlTests () diff --git a/bittide-instances/src/Bittide/Instances/Hitl/FincFdec.hs b/bittide-instances/src/Bittide/Instances/Hitl/FincFdec.hs index 36c5c0a32..1e8f04448 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/FincFdec.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/FincFdec.hs @@ -1,12 +1,12 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} --- | A couple of tests testing clock board programming, and subsequently the --- FINC and FDEC pins. +{- | A couple of tests testing clock board programming, and subsequently the +FINC and FDEC pins. +-} module Bittide.Instances.Hitl.FincFdec where import Clash.Annotations.TH (makeTopEntity) @@ -15,10 +15,13 @@ import Clash.Explicit.Prelude import Clash.Prelude (withClockResetEnable) import Clash.Xilinx.ClockGen (clockWizardDifferential) +import Bittide.ClockControl ( + SpeedChange (NoChange, SlowDown, SpeedUp), + speedChangeToFincFdec, + ) +import Bittide.ClockControl.Si539xSpi (ConfigState (Finished), si539xSpi) import Bittide.Counter (domainDiffCounter) -import Bittide.ClockControl (SpeedChange(NoChange, SlowDown, SpeedUp), speedChangeToFincFdec) -import Bittide.ClockControl.Si539xSpi (si539xSpi, ConfigState(Finished)) -import Bittide.Hitl (HitlTests, testsFromEnum, hitlVio, singleFpga) +import Bittide.Hitl (HitlTests, hitlVio, singleFpga, testsFromEnum) import Bittide.Instances.Domains import Data.Maybe (isJust) @@ -27,19 +30,20 @@ import qualified Bittide.ClockControl.Si5395J as Si5395J data TestState = Busy | Fail | Success data Test - -- | Keep pressing FDEC, see if counter falls below certain threshold - = FDec - -- | Keep pressing FINC, see if counter exceeds certain threshold - | FInc - -- | 'FDec' test followed by an 'FInc' one - | FDecInc - -- | 'FInc' test followed by an 'FDec' one - | FIncDec + = -- | Keep pressing FDEC, see if counter falls below certain threshold + FDec + | -- | Keep pressing FINC, see if counter exceeds certain threshold + FInc + | -- | 'FDec' test followed by an 'FInc' one + FDecInc + | -- | 'FInc' test followed by an 'FDec' one + FIncDec deriving (Enum, Generic, NFDataX, Bounded, BitPack, ShowX, Show) --- | Counter threshold after which a test is considered passed/failed. In theory --- clocks can diverge at +-20 kHz (at 200 MHz), which gives the tests 500 ms to --- adjust their clocks - which should be plenty. +{- | Counter threshold after which a test is considered passed/failed. In theory +clocks can diverge at +-20 kHz (at 200 MHz), which gives the tests 500 ms to +adjust their clocks - which should be plenty. +-} threshold :: Signed 32 threshold = 20_000 @@ -55,39 +59,36 @@ goFincFdecTests :: Clock Ext200 -> Signal Basic200 Test -> "MISO" ::: Signal Basic200 Bit -> -- SPI - "" ::: - ( Signal Basic200 TestState - - -- Freq increase / freq decrease request to clock board - , "" ::: - ( "FINC" ::: Signal Basic200 Bool - , "FDEC" ::: Signal Basic200 Bool - ) - - -- SPI to clock board: - , "" ::: - ( "SCLK" ::: Signal Basic200 Bool - , "MOSI" ::: Signal Basic200 Bit - , "CSB" ::: Signal Basic200 Bool - ) - - -- Debug signals: - , "" ::: - ( "SPI_BUSY" ::: Signal Basic200 Bool - , "SPI_STATE" ::: Signal Basic200 (BitVector 40) - , "SI_LOCKED" ::: Signal Basic200 Bool - , "COUNTER_ACTIVE" ::: Signal Basic200 Bool - , "COUNTER" ::: Signal Basic200 (Signed 32) - ) - ) + "" + ::: ( Signal Basic200 TestState + , -- Freq increase / freq decrease request to clock board + "" + ::: ( "FINC" ::: Signal Basic200 Bool + , "FDEC" ::: Signal Basic200 Bool + ) + , -- SPI to clock board: + "" + ::: ( "SCLK" ::: Signal Basic200 Bool + , "MOSI" ::: Signal Basic200 Bit + , "CSB" ::: Signal Basic200 Bool + ) + , -- Debug signals: + "" + ::: ( "SPI_BUSY" ::: Signal Basic200 Bool + , "SPI_STATE" ::: Signal Basic200 (BitVector 40) + , "SI_LOCKED" ::: Signal Basic200 Bool + , "COUNTER_ACTIVE" ::: Signal Basic200 Bool + , "COUNTER" ::: Signal Basic200 (Signed 32) + ) + ) goFincFdecTests clk rst clkControlled testSelect miso = (testResult, fIncDec, spiOut, debugSignals) where debugSignals = (spiBusy, pack <$> spiState, siClkLocked, counterActive, counter) - (_, spiBusy, spiState@(fmap (==Finished) -> siClkLocked), spiOut) = - withClockResetEnable clk rst enableGen $ - si539xSpi + (_, spiBusy, spiState@(fmap (== Finished) -> siClkLocked), spiOut) = + withClockResetEnable clk rst enableGen + $ si539xSpi Si5395J.testConfig6_200_on_0a_1ppb_and_0 (SNat @(Microseconds 1)) (pure Nothing) @@ -97,7 +98,8 @@ goFincFdecTests clk rst clkControlled testSelect miso = rstControlled = convertReset clk clkControlled rst (counter, counterActive) = - unbundle $ + unbundle + $ -- Note that in a "real" Bittide system the clocks would be wired up the -- other way around: the controlled domain would be the target domain. We -- don't do that here because we know 'rstControlled' will come out of @@ -108,8 +110,9 @@ goFincFdecTests clk rst clkControlled testSelect miso = fIncDec = unbundle $ speedChangeToFincFdec clk rstTest fIncDecRequest - (fIncDecRequest, testResult) = unbundle $ - (!!) + (fIncDecRequest, testResult) = + unbundle + $ (!!) <$> bundle (fDecResult :> fIncResult :> fDecIncResult :> fIncDecResult :> Nil) <*> fmap fromEnum testSelect @@ -121,16 +124,16 @@ goFincFdecTests clk rst clkControlled testSelect miso = -- Keep pressing FDEC, expect counter to go below -@threshold@ goFdec :: Signed 32 -> (SpeedChange, TestState) goFdec n - | n > threshold = (NoChange, Fail) + | n > threshold = (NoChange, Fail) | n < -threshold = (NoChange, Success) - | otherwise = (SlowDown, Busy) + | otherwise = (SlowDown, Busy) -- Keep pressing FINC, expect counter to go above @threshold@ goFinc :: Signed 32 -> (SpeedChange, TestState) goFinc n - | n > threshold = (NoChange, Success) + | n > threshold = (NoChange, Success) | n < -threshold = (NoChange, Fail) - | otherwise = (SpeedUp, Busy) + | otherwise = (SpeedUp, Busy) -- Keep pressing FDEC, expect counter to go below -@threshold@, then keep pressing -- FINC, expect counter to go above 0. @@ -138,53 +141,49 @@ goFincFdecTests clk rst clkControlled testSelect miso = goFdecFinc FDec n | n > threshold = (FDec, (NoChange, Fail)) | n < -threshold = (FInc, (NoChange, Busy)) - | otherwise = (FDec, (SlowDown, Busy)) + | otherwise = (FDec, (SlowDown, Busy)) goFdecFinc FInc n - | n > 0 = (FInc, (NoChange, Success)) - | n < -(3*threshold) = (FInc, (NoChange, Fail)) - | otherwise = (FInc, (SpeedUp, Busy)) + | n > 0 = (FInc, (NoChange, Success)) + | n < -(3 * threshold) = (FInc, (NoChange, Fail)) + | otherwise = (FInc, (SpeedUp, Busy)) goFdecFinc s _ = (s, (NoChange, Fail)) -- Illegal state -- Keep pressing FINC, expect counter to go above @threshold@, then keep pressing -- FDEC, expect counter to go below 0. goFincFdec :: Test -> Signed 32 -> (Test, (SpeedChange, TestState)) goFincFdec FInc n - | n > threshold = (FDec, (NoChange, Busy)) + | n > threshold = (FDec, (NoChange, Busy)) | n < -threshold = (FInc, (NoChange, Fail)) - | otherwise = (FInc, (SpeedUp, Busy)) + | otherwise = (FInc, (SpeedUp, Busy)) goFincFdec FDec n | n > (3 * threshold) = (FDec, (NoChange, Fail)) - | n < 0 = (FDec, (NoChange, Success)) - | otherwise = (FDec, (SlowDown, Busy)) + | n < 0 = (FDec, (NoChange, Success)) + | otherwise = (FDec, (SlowDown, Busy)) goFincFdec s _ = (s, (NoChange, Fail)) -- Illegal state fincFdecTests :: -- Pins from internal oscillator: "CLK_125MHZ" ::: DiffClock Ext125 -> - -- Pins from clock board: "USER_SMA_CLOCK" ::: DiffClock Ext200 -> "MISO" ::: Signal Basic200 Bit -> -- SPI - - "" ::: - ( "" ::: - ( "done" ::: Signal Basic200 Bool - , "success" ::: Signal Basic200 Bool - ) - - -- Freq increase / freq decrease request to clock board - , "" ::: - ( "FINC" ::: Signal Basic200 Bool - , "FDEC" ::: Signal Basic200 Bool - ) - - -- SPI to clock board: - , "" ::: - ( "SCLK" ::: Signal Basic200 Bool - , "MOSI" ::: Signal Basic200 Bit - , "CSB" ::: Signal Basic200 Bool - ) - ) + "" + ::: ( "" + ::: ( "done" ::: Signal Basic200 Bool + , "success" ::: Signal Basic200 Bool + ) + , -- Freq increase / freq decrease request to clock board + "" + ::: ( "FINC" ::: Signal Basic200 Bool + , "FDEC" ::: Signal Basic200 Bool + ) + , -- SPI to clock board: + "" + ::: ( "SCLK" ::: Signal Basic200 Bool + , "MOSI" ::: Signal Basic200 Bit + , "CSB" ::: Signal Basic200 Bool + ) + ) fincFdecTests diffClk controlledDiffClock spiIn = ((testDone, testSuccess), fIncDec, spiOut) where diff --git a/bittide-instances/src/Bittide/Instances/Hitl/FullMeshHwCc.hs b/bittide-instances/src/Bittide/Instances/Hitl/FullMeshHwCc.hs index 5ff97c261..4dd0ebaee 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/FullMeshHwCc.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/FullMeshHwCc.hs @@ -3,38 +3,37 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedRecordDot #-} - -{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} +{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} --- | Test whether clock boards are configurable and transceiver links come --- online. If they do, run clock control and wait for the clocks to stabilize. --- This assumes to run on a fully connected mesh of 8 FPGAs. Also see --- 'c_CHANNEL_NAMES' and 'c_CLOCK_PATHS'. It has two tricks up its sleeve: --- --- 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming --- its clock boards at the same time. --- --- 2. It keeps track of how many times the GTH's reset manager had to reset --- the connection and how often it lost connections after establishing --- them. --- --- This test will succeed if all clocks have been stable for 5 seconds. Note: --- this doesn't test reframing yet. --- -module Bittide.Instances.Hitl.FullMeshHwCc - ( fullMeshHwCcWithRiscvTest - , fullMeshHwCcTest - , clockControlConfig - , tests - ) where +{- | Test whether clock boards are configurable and transceiver links come +online. If they do, run clock control and wait for the clocks to stabilize. +This assumes to run on a fully connected mesh of 8 FPGAs. Also see +'c_CHANNEL_NAMES' and 'c_CLOCK_PATHS'. It has two tricks up its sleeve: + + 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming + its clock boards at the same time. + + 2. It keeps track of how many times the GTH's reset manager had to reset + the connection and how often it lost connections after establishing + them. + +This test will succeed if all clocks have been stable for 5 seconds. Note: +this doesn't test reframing yet. +-} +module Bittide.Instances.Hitl.FullMeshHwCc ( + fullMeshHwCcWithRiscvTest, + fullMeshHwCcTest, + clockControlConfig, + tests, +) where -import Clash.Prelude (withClockResetEnable) import Clash.Explicit.Prelude hiding (PeriodToCycles) import qualified Clash.Explicit.Prelude as E +import Clash.Prelude (withClockResetEnable) import Data.Maybe (fromMaybe) import Data.Proxy @@ -45,24 +44,25 @@ import System.FilePath import Bittide.Arithmetic.Time import Bittide.ClockControl import Bittide.ClockControl.Callisto -import Bittide.ClockControl.Callisto.Util (FINC, FDEC, stickyBits, speedChangeToPins) +import Bittide.ClockControl.Callisto.Util (FDEC, FINC, speedChangeToPins, stickyBits) import Bittide.ClockControl.Registers (clockControlWb) import Bittide.ClockControl.Si5395J -import Bittide.ClockControl.Si539xSpi (ConfigState(Error, Finished), si539xSpi) -import Bittide.DoubleBufferedRam - ( InitialContent(Reloadable), ContentType(Blob) - , RegisterWritePriority(CircuitPriority) - , registerWb - ) +import Bittide.ClockControl.Si539xSpi (ConfigState (Error, Finished), si539xSpi) import Bittide.Counter +import Bittide.DoubleBufferedRam ( + ContentType (Blob), + InitialContent (Reloadable), + RegisterWritePriority (CircuitPriority), + registerWb, + ) import Bittide.ElasticBuffer (sticky) -import Bittide.Hitl (HitlTestsWithPostProcData, hitlVioBool, allFpgas) +import Bittide.Hitl (HitlTestsWithPostProcData, allFpgas, hitlVioBool) import Bittide.Instances.Domains -import Bittide.ProcessingElement (PeConfig(..), processingElement) +import Bittide.ProcessingElement (PeConfig (..), processingElement) import Bittide.ProcessingElement.Util (memBlobsFromElf) -import Bittide.Simulate.Config (SimConf(..)) -import Bittide.SharedTypes (Bytes, ByteOrder(BigEndian)) -import Bittide.Topology (TopologyType(..)) +import Bittide.SharedTypes (ByteOrder (BigEndian), Bytes) +import Bittide.Simulate.Config (SimConf (..)) +import Bittide.Topology (TopologyType (..)) import Bittide.Transceiver (transceiverPrbsN) import Bittide.Instances.Hitl.IlaPlot @@ -72,7 +72,7 @@ import Project.FilePath import Clash.Annotations.TH (makeTopEntity) import Clash.Class.Counter import Clash.Cores.Xilinx.GTH -import Clash.Cores.Xilinx.Ila (IlaConfig(..), Depth(..), ila, ilaConfig) +import Clash.Cores.Xilinx.Ila (Depth (..), IlaConfig (..), ila, ilaConfig) import Clash.Sized.Extra (unsignedToSigned) import Clash.Xilinx.ClockGen @@ -85,16 +85,17 @@ import qualified Bittide.Transceiver.ResetManager as ResetManager import qualified Data.Map as Map (singleton) clockControlConfig :: - $(case (instancesClockConfig (Proxy @Basic125)) of { (_ :: t) -> liftTypeQ @t }) + $(case (instancesClockConfig (Proxy @Basic125)) of (_ :: t) -> liftTypeQ @t) clockControlConfig = $(lift (instancesClockConfig (Proxy @Basic125))) --- | Instantiates a RiscV core that copies instructions coming from a hardware --- implementation of Callisto (see 'fullMeshHwTest') and copies it to a register --- tied to FINC/FDEC. +{- | Instantiates a RiscV core that copies instructions coming from a hardware +implementation of Callisto (see 'fullMeshHwTest') and copies it to a register +tied to FINC/FDEC. +-} fullMeshRiscvCopyTest :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => Clock dom -> Reset dom -> Signal dom (CallistoResult LinkCount) -> @@ -105,17 +106,22 @@ fullMeshRiscvCopyTest :: ) fullMeshRiscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec where - (_, fIncDec) = toSignals - ( circuit $ \jtag -> do - [wbA, wbB] <- withClockResetEnable clk rst enableGen $ processingElement @dom peConfig -< jtag - fIncDecCallisto -< wbA - (fIncDec, _allStable) <- withClockResetEnable clk rst enableGen $ - clockControlWb margin framesize (pure $ complement 0) dataCounts -< wbB - idC -< fIncDec - ) (pure $ JtagIn low low low, pure ()) + (_, fIncDec) = + toSignals + ( circuit $ \jtag -> do + [wbA, wbB] <- + withClockResetEnable clk rst enableGen $ processingElement @dom peConfig -< jtag + fIncDecCallisto -< wbA + (fIncDec, _allStable) <- + withClockResetEnable clk rst enableGen + $ clockControlWb margin framesize (pure $ complement 0) dataCounts + -< wbB + idC -< fIncDec + ) + (pure $ JtagIn low low low, pure ()) fIncDecCallisto :: - forall aw nBytes . + forall aw nBytes. (KnownNat aw, 2 <= aw, nBytes ~ 4) => Circuit (Wishbone dom 'Standard aw (Bytes nBytes)) @@ -124,12 +130,13 @@ fullMeshRiscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec where goFIncDecCallisto (wbM2S, _) = (wbS2M, ()) where - (_, wbS2M) = withClockResetEnable clk rst enableGen $ - registerWb - CircuitPriority - (0 :: Bytes nBytes, 0 :: Bytes nBytes) - wbM2S - (fmap (fmap ((,0) . extend . pack)) fincfdec) + (_, wbS2M) = + withClockResetEnable clk rst enableGen + $ registerWb + CircuitPriority + (0 :: Bytes nBytes, 0 :: Bytes nBytes) + wbM2S + (fmap (fmap ((,0) . extend . pack)) fincfdec) fincfdec :: Signal dom (Maybe SpeedChange) fincfdec = @@ -141,22 +148,24 @@ fullMeshRiscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec -- this doesn't happen). This makes sure the RiscV doesn't read the same -- result from the hardware clock control twice. clearOnAck :: ("ACK" ::: Bool) -> Maybe SpeedChange -> Maybe SpeedChange - clearOnAck False maybeSpeedChange = maybeSpeedChange - clearOnAck True (Just speedChange) = Just speedChange - clearOnAck True Nothing = Just NoChange + clearOnAck False maybeSpeedChange = maybeSpeedChange + clearOnAck True (Just speedChange) = Just speedChange + clearOnAck True Nothing = Just NoChange margin = d2 framesize = SNat @(PeriodToCycles dom (Seconds 1)) - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release - elfPath = elfDir "clock-control-reg-cpy" - iSize = 64 * 1024 -- 64 KB - dSize = 64 * 1024 -- 64 KB - memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing) + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release + elfPath = elfDir "clock-control-reg-cpy" + iSize = 64 * 1024 -- 64 KB + dSize = 64 * 1024 -- 64 KB + memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing + ) {- 0b10xxxxx_xxxxxxxx 0b10 0x8x instruction memory @@ -170,9 +179,10 @@ fullMeshRiscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec (Reloadable $ Blob iMem) (Reloadable $ Blob dMem) --- | Instantiates a hardware implementation of Callisto and exports its results. Can --- be used to drive FINC/FDEC directly (see @FINC_FDEC@ result) or to tie the --- results to a RiscV core (see 'fullMeshRiscvCopyTest') +{- | Instantiates a hardware implementation of Callisto and exports its results. Can +be used to drive FINC/FDEC directly (see @FINC_FDEC@ result) or to tie the +results to a RiscV core (see 'fullMeshRiscvCopyTest') +-} fullMeshHwTest :: "SMA_MGT_REFCLK_C" ::: Clock Ext200 -> "SYSCLK" ::: Clock Basic125 -> @@ -188,50 +198,55 @@ fullMeshHwTest :: , "DATA_COUNTERS" ::: Vec LinkCount (Signal Basic125 (RelDataCount 32)) , "stats" ::: Vec LinkCount (Signal Basic125 ResetManager.Statistics) , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) , "transceiversFailedAfterUp" ::: Signal Basic125 Bool , "ALL_READY" ::: Signal Basic125 Bool - , "ALL_STABLE" ::: Signal Basic125 Bool + , "ALL_STABLE" ::: Signal Basic125 Bool ) fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = - fincFdecIla `hwSeqX` - ( transceivers.txNs - , transceivers.txPs - , frequencyAdjustments - , callistoResult - , clockControlReset - , domainDiffs - , transceivers.stats - , spiDone - , spiOut - , transceiversFailedAfterUp - , allReady - , allStable0 - ) + fincFdecIla + `hwSeqX` ( transceivers.txNs + , transceivers.txPs + , frequencyAdjustments + , callistoResult + , clockControlReset + , domainDiffs + , transceivers.stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable0 + ) where syncRst = rst `orReset` (unsafeFromActiveLow (fmap not spiErr)) -- Clock programming - spiDone = E.dflipflop sysClk $ (==Finished) <$> spiState + spiDone = E.dflipflop sysClk $ (== Finished) <$> spiState spiErr = E.dflipflop sysClk $ isErr <$> spiState isErr (Error _) = True - isErr _ = False + isErr _ = False (_, _, spiState, spiOut) = - withClockResetEnable sysClk syncRst enableGen $ - si539xSpi testConfig6_200_on_0a_10ppb (SNat @(Microseconds 10)) (pure Nothing) miso + withClockResetEnable sysClk syncRst enableGen + $ si539xSpi testConfig6_200_on_0a_10ppb (SNat @(Microseconds 10)) (pure Nothing) miso -- Transceiver setup gthAllReset = unsafeFromActiveLow spiDone transceivers = transceiverPrbsN - @GthTx @GthRx @Ext200 @Basic125 @GthTxS @GthRxS + @GthTx + @GthRx + @Ext200 + @Basic125 + @GthTxS + @GthRxS Transceiver.defConfig Transceiver.Inputs { clock = sysClk @@ -246,7 +261,8 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = , rxReadys = repeat (pure True) } - allReady = trueFor (SNat @(Milliseconds 500)) sysClk syncRst (and <$> bundle transceivers.linkReadys) + allReady = + trueFor (SNat @(Milliseconds 500)) sysClk syncRst (and <$> bundle transceivers.linkReadys) transceiversFailedAfterUp = sticky sysClk syncRst (isFalling sysClk syncRst enableGen False allReady) @@ -256,21 +272,28 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = -- Clock control clockControlReset = - orReset (unsafeFromActiveLow allReady) - $ orReset (unsafeFromActiveHigh transceiversFailedAfterUp) - (unsafeFromActiveLow syncStart) + orReset (unsafeFromActiveLow allReady) + $ orReset + (unsafeFromActiveHigh transceiversFailedAfterUp) + (unsafeFromActiveLow syncStart) availableLinkMask = pure maxBound - (clockMod, _stabilities, allStable0, _allCentered) = unbundle $ - fmap - (\CallistoResult{..} -> (maybeSpeedChange, stability, allStable, allSettled)) - callistoResult + (clockMod, _stabilities, allStable0, _allCentered) = + unbundle + $ fmap + (\CallistoResult{..} -> (maybeSpeedChange, stability, allStable, allSettled)) + callistoResult callistoResult = callistoClockControlWithIla @LinkCount @CccBufferSize - (head transceivers.txClocks) sysClk clockControlReset clockControlConfig - IlaControl{..} availableLinkMask (fmap (fmap resize) domainDiffs) + (head transceivers.txClocks) + sysClk + clockControlReset + clockControlConfig + IlaControl{..} + availableLinkMask + (fmap (fmap resize) domainDiffs) -- Capture every 100 microseconds - this should give us a window of about 5 -- seconds. Or: when we're in reset. If we don't do the latter, the VCDs get @@ -278,51 +301,64 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = capture = (captureFlag .&&. allReady) .||. unsafeToActiveHigh syncRst fincFdecIla :: Signal Basic125 () - fincFdecIla = setName @"fincFdecIla" $ ila - (ilaConfig $ - "trigger_0" - :> "capture_0" - :> "probe_milliseconds" - :> "probe_allStable0" - :> "probe_transceiversFailedAfterUp" - :> "probe_nFincs" - :> "probe_nFdecs" - :> "probe_net_nFincs" - :> Nil - ){depth = D16384} - sysClk - - -- Trigger as soon as we come out of reset - (unsafeToActiveLow syncRst) - - capture - - -- Debug probes - milliseconds1 - allStable0 - transceiversFailedAfterUp - nFincs - nFdecs - (fmap unsignedToSigned nFincs - fmap unsignedToSigned nFdecs) - - captureFlag = riseEvery sysClk syncRst enableGen - (SNat @(PeriodToCycles Basic125 (Milliseconds 1))) - - nFincs = regEn sysClk clockControlReset enableGen - (0 :: Unsigned 32) - ((== Just SpeedUp) <$> clockMod) - (satSucc SatBound <$> nFincs) - - nFdecs = regEn sysClk clockControlReset enableGen - (0 :: Unsigned 32) - ((== Just SlowDown) <$> clockMod) - (satSucc SatBound <$> nFdecs) + fincFdecIla = + setName @"fincFdecIla" + $ ila + ( ilaConfig + $ "trigger_0" + :> "capture_0" + :> "probe_milliseconds" + :> "probe_allStable0" + :> "probe_transceiversFailedAfterUp" + :> "probe_nFincs" + :> "probe_nFdecs" + :> "probe_net_nFincs" + :> Nil + ) + { depth = D16384 + } + sysClk + -- Trigger as soon as we come out of reset + (unsafeToActiveLow syncRst) + capture + -- Debug probes + milliseconds1 + allStable0 + transceiversFailedAfterUp + nFincs + nFdecs + (fmap unsignedToSigned nFincs - fmap unsignedToSigned nFdecs) + + captureFlag = + riseEvery + sysClk + syncRst + enableGen + (SNat @(PeriodToCycles Basic125 (Milliseconds 1))) + + nFincs = + regEn + sysClk + clockControlReset + enableGen + (0 :: Unsigned 32) + ((== Just SpeedUp) <$> clockMod) + (satSucc SatBound <$> nFincs) + + nFdecs = + regEn + sysClk + clockControlReset + enableGen + (0 :: Unsigned 32) + ((== Just SlowDown) <$> clockMod) + (satSucc SatBound <$> nFdecs) frequencyAdjustments :: Signal Basic125 (FINC, FDEC) frequencyAdjustments = - E.delay sysClk enableGen minBound {- glitch filter -} $ - withClockResetEnable sysClk clockControlReset enableGen $ - stickyBits @Basic125 d20 (speedChangeToPins . fromMaybe NoChange <$> clockMod) + E.delay sysClk enableGen minBound {- glitch filter -} + $ withClockResetEnable sysClk clockControlReset enableGen + $ stickyBits @Basic125 d20 (speedChangeToPins . fromMaybe NoChange <$> clockMod) domainDiffs = domainDiffCounterExt sysClk clockControlReset @@ -339,17 +375,17 @@ fullMeshHwCcWithRiscvTest :: "MISO" ::: Signal Basic125 Bit -> ( "GTH_TX_NS" ::: TransceiverWires GthTxS LinkCount , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount - , "" ::: - ( "FINC" ::: Signal Basic125 Bool - , "FDEC" ::: Signal Basic125 Bool - ) + , "" + ::: ( "FINC" ::: Signal Basic125 Bool + , "FDEC" ::: Signal Basic125 Bool + ) , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) fullMeshHwCcWithRiscvTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, (riscvFinc, riscvFdec), syncOut, spiDone, spiOut) @@ -360,17 +396,30 @@ fullMeshHwCcWithRiscvTest refClkDiff sysClkDiff syncIn rxns rxps miso = ilaControl@IlaControl{..} = ilaPlotSetup IlaPlotSetup{..} - ( txns, txps, _hwFincFdecs, callistoResult, callistoReset - , dataCounts, _stats, spiDone, spiOut, transceiversFailedAfterUp, allReady - , allStable ) = fullMeshHwTest refClk sysClk ilaControl rxns rxps miso + ( txns + , txps + , _hwFincFdecs + , callistoResult + , callistoReset + , dataCounts + , _stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable + ) = fullMeshHwTest refClk sysClk ilaControl rxns rxps miso (riscvFinc, riscvFdec) = fullMeshRiscvCopyTest sysClk callistoReset callistoResult dataCounts -- check that tests are not synchronously start before all -- transceivers are up - startBeforeAllReady = sticky sysClk syncRst - (startTest .&&. syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) + startBeforeAllReady = + sticky + sysClk + syncRst + (startTest .&&. syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) endSuccess :: Signal Basic125 Bool endSuccess = trueFor (SNat @(Seconds 5)) sysClk syncRst allStable @@ -380,6 +429,7 @@ fullMeshHwCcWithRiscvTest refClkDiff sysClkDiff syncIn rxns rxps miso = startTest :: Signal Basic125 Bool startTest = hitlVioBool sysClk done success + makeTopEntity 'fullMeshHwCcWithRiscvTest -- | Top entity for this test. See module documentation for more information. @@ -392,17 +442,17 @@ fullMeshHwCcTest :: "MISO" ::: Signal Basic125 Bit -> ( "GTH_TX_NS" ::: TransceiverWires GthTxS LinkCount , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount - , "" ::: - ( "FINC" ::: Signal Basic125 Bool - , "FDEC" ::: Signal Basic125 Bool - ) + , "" + ::: ( "FINC" ::: Signal Basic125 Bool + , "FDEC" ::: Signal Basic125 Bool + ) , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) fullMeshHwCcTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, unbundle hwFincFdecs, syncOut, spiDone, spiOut) @@ -411,14 +461,27 @@ fullMeshHwCcTest refClkDiff sysClkDiff syncIn rxns rxps miso = (sysClk, sysRst) = clockWizardDifferential sysClkDiff noReset ilaControl@IlaControl{..} = ilaPlotSetup IlaPlotSetup{..} - ( txns, txps, hwFincFdecs, _callistoResult, _callistoReset - , _dataCounts, _stats, spiDone, spiOut, transceiversFailedAfterUp, allReady - , allStable ) = fullMeshHwTest refClk sysClk ilaControl rxns rxps miso + ( txns + , txps + , hwFincFdecs + , _callistoResult + , _callistoReset + , _dataCounts + , _stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable + ) = fullMeshHwTest refClk sysClk ilaControl rxns rxps miso -- check that tests are not synchronously start before all -- transceivers are up - startBeforeAllReady = sticky sysClk syncRst - (syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) + startBeforeAllReady = + sticky + sysClk + syncRst + (syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) endSuccess :: Signal Basic125 Bool endSuccess = trueFor (SNat @(Seconds 5)) sysClk syncRst allStable @@ -427,28 +490,29 @@ fullMeshHwCcTest refClkDiff sysClkDiff syncIn rxns rxps miso = startTest = hitlVioBool sysClk - -- done (endSuccess .||. transceiversFailedAfterUp .||. startBeforeAllReady) - -- success (not <$> (transceiversFailedAfterUp .||. startBeforeAllReady)) + makeTopEntity 'fullMeshHwCcTest tests :: HitlTestsWithPostProcData () SimConf -tests = Map.singleton "CC" $ - ( allFpgas () - , def { mTopologyType = Just $ Complete (natToInteger @FpgaCount) - , samples = 1000 - , duration = natToNum @(PeriodToCycles Basic125 (Seconds 60)) - , stabilityMargin = snatToNum cccStabilityCheckerMargin - , stabilityFrameSize = snatToNum cccStabilityCheckerFramesize - , reframe = cccEnableReframing - , rusty = cccEnableRustySimulation - , waitTime = fromEnum cccReframingWaitTime - , clockOffsets = toList $ repeat @FpgaCount 0 - , startupDelays = toList $ repeat @FpgaCount 0 - } - ) +tests = + Map.singleton "CC" + $ ( allFpgas () + , def + { mTopologyType = Just $ Complete (natToInteger @FpgaCount) + , samples = 1000 + , duration = natToNum @(PeriodToCycles Basic125 (Seconds 60)) + , stabilityMargin = snatToNum cccStabilityCheckerMargin + , stabilityFrameSize = snatToNum cccStabilityCheckerFramesize + , reframe = cccEnableReframing + , rusty = cccEnableRustySimulation + , waitTime = fromEnum cccReframingWaitTime + , clockOffsets = toList $ repeat @FpgaCount 0 + , startupDelays = toList $ repeat @FpgaCount 0 + } + ) where ClockControlConfig{..} = clockControlConfig diff --git a/bittide-instances/src/Bittide/Instances/Hitl/FullMeshSwCc.hs b/bittide-instances/src/Bittide/Instances/Hitl/FullMeshSwCc.hs index 09e10a814..6570becb8 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/FullMeshSwCc.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/FullMeshSwCc.hs @@ -7,35 +7,34 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} +{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} --- | Test whether clock boards are configurable and transceiver links come --- online. If they do, run clock control in software and wait for the clocks to --- stabilize. This assumes to run on a fully connected mesh of 8 FPGAs. Also see --- 'Bittide.Instances.Hitl.Setup'. It has two tricks up its sleeve: --- --- 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming --- its clock boards at the same time. --- --- 2. It keeps track of how many times the GTH's reset manager had to reset --- the connection and how often it lost connections after establishing --- them. --- --- This test will succeed if all clocks have been stable for 5 seconds. Note: --- this doesn't test reframing yet. --- -module Bittide.Instances.Hitl.FullMeshSwCc - ( fullMeshSwCcTest - , clockControlConfig - , tests - ) where +{- | Test whether clock boards are configurable and transceiver links come +online. If they do, run clock control in software and wait for the clocks to +stabilize. This assumes to run on a fully connected mesh of 8 FPGAs. Also see +'Bittide.Instances.Hitl.Setup'. It has two tricks up its sleeve: + + 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming + its clock boards at the same time. + + 2. It keeps track of how many times the GTH's reset manager had to reset + the connection and how often it lost connections after establishing + them. + +This test will succeed if all clocks have been stable for 5 seconds. Note: +this doesn't test reframing yet. +-} +module Bittide.Instances.Hitl.FullMeshSwCc ( + fullMeshSwCcTest, + clockControlConfig, + tests, +) where -import qualified Prelude as P -import Clash.Prelude (withClockResetEnable) import Clash.Explicit.Prelude hiding (PeriodToCycles) import qualified Clash.Explicit.Prelude as E +import Clash.Prelude (withClockResetEnable) +import qualified Prelude as P import Data.Maybe (fromMaybe) import Data.Proxy @@ -46,35 +45,34 @@ import System.FilePath import Bittide.Arithmetic.Time import Bittide.ClockControl import Bittide.ClockControl.Callisto -import Bittide.ClockControl.Callisto.Util (FINC, FDEC, stickyBits, speedChangeToPins) +import Bittide.ClockControl.Callisto.Util (FDEC, FINC, speedChangeToPins, stickyBits) import Bittide.ClockControl.Registers (clockControlWb) import Bittide.ClockControl.Si5395J -import Bittide.ClockControl.Si539xSpi (ConfigState(Error, Finished), si539xSpi) +import Bittide.ClockControl.Si539xSpi (ConfigState (Error, Finished), si539xSpi) import Bittide.Counter -import Bittide.DoubleBufferedRam (InitialContent(Reloadable), ContentType(Blob)) -import Bittide.ElasticBuffer (resettableXilinxElasticBuffer, sticky, Underflow, Overflow) -import Bittide.Hitl (HitlTestsWithPostProcData, hitlVioBool, allFpgas) +import Bittide.DoubleBufferedRam (ContentType (Blob), InitialContent (Reloadable)) +import Bittide.ElasticBuffer (Overflow, Underflow, resettableXilinxElasticBuffer, sticky) +import Bittide.Hitl (HitlTestsWithPostProcData, allFpgas, hitlVioBool) import Bittide.Instances.Domains -import Bittide.ProcessingElement (PeConfig(..), processingElement) +import Bittide.ProcessingElement (PeConfig (..), processingElement) import Bittide.ProcessingElement.Util (memBlobsFromElf) -import Bittide.SharedTypes (ByteOrder(BigEndian)) -import Bittide.Simulate.Config (SimConf(..)) -import Bittide.Topology (TopologyType(..)) +import Bittide.SharedTypes (ByteOrder (BigEndian)) +import Bittide.Simulate.Config (SimConf (..)) +import Bittide.Topology (TopologyType (..)) import Bittide.Transceiver (transceiverPrbsN) - import Bittide.Instances.Hitl.IlaPlot -import Bittide.Instances.Hitl.Setup hiding (FpgaCount,LinkCount) +import Bittide.Instances.Hitl.Setup hiding (FpgaCount, LinkCount) import Project.FilePath import Clash.Annotations.TH (makeTopEntity) import Clash.Class.Counter import Clash.Cores.Xilinx.GTH -import Clash.Cores.Xilinx.Ila (IlaConfig(..), Depth(..), ila, ilaConfig) +import Clash.Cores.Xilinx.Ila (Depth (..), IlaConfig (..), ila, ilaConfig) import Clash.Cores.Xilinx.Xpm.Cdc (xpmCdcSingle) import Clash.Cores.Xilinx.Xpm.Cdc.Handshake.Extra (xpmCdcMaybeLossy) -import Clash.Sized.Vector.ToTuple (vecToTuple) import Clash.Sized.Extra (unsignedToSigned) +import Clash.Sized.Vector.ToTuple (vecToTuple) import Clash.Xilinx.ClockGen import Protocols @@ -89,14 +87,14 @@ type FpgaCount = 8 type LinkCount = FpgaCount - 1 clockControlConfig :: - $(case (instancesClockConfig (Proxy @Basic125)) of { (_ :: t) -> liftTypeQ @t }) + $(case (instancesClockConfig (Proxy @Basic125)) of (_ :: t) -> liftTypeQ @t) clockControlConfig = $(lift (instancesClockConfig (Proxy @Basic125))) -- | Instantiates a RiscV core fullMeshRiscvTest :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => Clock dom -> Reset dom -> Vec LinkCount (Signal dom (RelDataCount 32)) -> @@ -106,26 +104,32 @@ fullMeshRiscvTest :: ) fullMeshRiscvTest clk rst dataCounts = unbundle fIncDec where - (_, fIncDec) = toSignals - ( circuit $ \jtag -> do - [wbB] <- withClockResetEnable clk rst enableGen $ processingElement @dom peConfig -< jtag - (fIncDec, _allStable) <- withClockResetEnable clk rst enableGen $ - clockControlWb margin framesize (pure $ complement 0) dataCounts -< wbB - idC -< fIncDec - ) (pure $ JtagIn low low low, pure ()) + (_, fIncDec) = + toSignals + ( circuit $ \jtag -> do + [wbB] <- withClockResetEnable clk rst enableGen $ processingElement @dom peConfig -< jtag + (fIncDec, _allStable) <- + withClockResetEnable clk rst enableGen + $ clockControlWb margin framesize (pure $ complement 0) dataCounts + -< wbB + idC -< fIncDec + ) + (pure $ JtagIn low low low, pure ()) margin = d2 framesize = SNat @(PeriodToCycles dom (Seconds 1)) - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release - elfPath = elfDir "clock-control" - iSize = 64 * 1024 -- 64 KB - dSize = 64 * 1024 -- 64 KB - memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing) + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release + elfPath = elfDir "clock-control" + iSize = 64 * 1024 -- 64 KB + dSize = 64 * 1024 -- 64 KB + memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing + ) {- 0b10xxxxx_xxxxxxxx 0b10 0x8x instruction memory @@ -138,7 +142,7 @@ fullMeshRiscvTest clk rst dataCounts = unbundle fIncDec (Reloadable $ Blob iMem) (Reloadable $ Blob dMem) -type FifoSize = 5 -- = 2^5 = 32 +type FifoSize = 5 -- = 2^5 = 32 -- | Instantiates a hardware implementation of Callisto and exports its results. fullMeshHwTest :: @@ -156,52 +160,58 @@ fullMeshHwTest :: , "DATA_COUNTERS" ::: Vec LinkCount (Signal Basic125 (RelDataCount 32)) , "stats" ::: Vec LinkCount (Signal Basic125 ResetManager.Statistics) , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) , "transceiversFailedAfterUp" ::: Signal Basic125 Bool , "ALL_UP" ::: Signal Basic125 Bool - , "ALL_STABLE" ::: Signal Basic125 Bool + , "ALL_STABLE" ::: Signal Basic125 Bool , "ugnsStable" ::: Vec LinkCount (Signal Basic125 Bool) ) fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = - fincFdecIla `hwSeqX` - ( transceivers.txNs - , transceivers.txPs - , frequencyAdjustments - , callistoResult - , clockControlReset - , domainDiffs - , transceivers.stats - , spiDone - , spiOut - , transceiversFailedAfterUp - , allReady - , allStable1 - , map (fmap (\(_,_,x,_) -> x)) freeUgnDatas - ) + fincFdecIla + `hwSeqX` ( transceivers.txNs + , transceivers.txPs + , frequencyAdjustments + , callistoResult + , clockControlReset + , domainDiffs + , transceivers.stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable1 + , map (fmap (\(_, _, x, _) -> x)) freeUgnDatas + ) where syncRst = rst `orReset` (unsafeFromActiveLow (fmap not spiErr)) -- Clock programming - spiDone = E.dflipflop sysClk $ (==Finished) <$> spiState + spiDone = E.dflipflop sysClk $ (== Finished) <$> spiState spiErr = E.dflipflop sysClk $ isErr <$> spiState isErr (Error _) = True - isErr _ = False + isErr _ = False (_, _, spiState, spiOut) = - withClockResetEnable sysClk syncRst enableGen $ - si539xSpi testConfig6_200_on_0a_10ppb (SNat @(Microseconds 10)) (pure Nothing) miso + withClockResetEnable sysClk syncRst enableGen + $ si539xSpi testConfig6_200_on_0a_10ppb (SNat @(Microseconds 10)) (pure Nothing) miso -- Transceiver setup gthAllReset = unsafeFromActiveLow spiDone transceivers = transceiverPrbsN - @GthTx @GthRx @Ext200 @Basic125 @GthTxS @GthRxS @LinkCount + @GthTx + @GthRx + @Ext200 + @Basic125 + @GthTxS + @GthRxS + @LinkCount Transceiver.defConfig Transceiver.Inputs { clock = sysClk @@ -217,35 +227,43 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = } txAllStables = zipWith (xpmCdcSingle sysClk) transceivers.txClocks (repeat allStable1) allStable1 = sticky sysClk syncRst allStable0 - txResets2 = zipWith orReset - transceivers.txResets - (map unsafeFromActiveLow txAllStables) + txResets2 = + zipWith + orReset + transceivers.txResets + (map unsafeFromActiveLow txAllStables) txCounters = zipWith txCounter transceivers.txClocks txResets2 txCounter txClk txRst = result where result = register txClk txRst enableGen (0xaabbccddeeff1234 :: BitVector 64) (result + 1) - -- see NOTE [magic start values] + -- see NOTE [magic start values] -- rxFifos :: Vec LinkCount (_, _, _, _, _Signal GthRx (Maybe (BitVector 64))) - rxFifos = zipWith4 go transceivers.txClocks transceivers.rxClocks - txResets2 - transceivers.rxDatas + rxFifos = + zipWith4 + go + transceivers.txClocks + transceivers.rxClocks + txResets2 + transceivers.rxDatas where go rClk wClk rRst = resettableXilinxElasticBuffer @FifoSize @_ @_ @(Maybe (BitVector 64)) rClk wClk rRst - (fillLvls,fifoUnderflowsTx,fifoOverflowsTx,_ebMode,rxCntrs) = unzip5 rxFifos + (fillLvls, fifoUnderflowsTx, fifoOverflowsTx, _ebMode, rxCntrs) = unzip5 rxFifos fifoOverflowsFree :: Vec LinkCount (Signal Basic125 Overflow) fifoOverflowsFree = zipWith (flip xpmCdcSingle sysClk) transceivers.txClocks fifoOverflowsTx fifoUnderflowsFree :: Vec LinkCount (Signal Basic125 Underflow) fifoUnderflowsFree = zipWith (flip xpmCdcSingle sysClk) transceivers.txClocks fifoUnderflowsTx - ugns :: Vec LinkCount (Signal GthTx (BitVector 64)) - ugns = zipWith (-) txCounters - (map (fmap (fromMaybe 0x1122334411223344)) rxCntrs) + ugns = + zipWith + (-) + txCounters + (map (fmap (fromMaybe 0x1122334411223344)) rxCntrs) -- see NOTE [magic start values] -- NOTE [magic start values] @@ -261,20 +279,31 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = freeUgnDatas = zipWith5 go transceivers.txClocks (repeat sysClk) ugns fillLvls ugnStable1sec where go clkIn clkOut ugn fillLvl stable = - regMaybe clkOut noReset enableGen (0,0,False, unpack 0) (xpmCdcMaybeLossy clkIn clkOut inp) + regMaybe + clkOut + noReset + enableGen + (0, 0, False, unpack 0) + (xpmCdcMaybeLossy clkIn clkOut inp) where fillStat = fillStats clkIn noReset fillLvl - inp = (fmap Just $ bundle (ugn,fillLvl,stable,fillStat)) - - (ugnD0, ugnD1, ugnD2, ugnD3, ugnD4, ugnD5, ugnD6 + inp = (fmap Just $ bundle (ugn, fillLvl, stable, fillStat)) + + ( ugnD0 + , ugnD1 + , ugnD2 + , ugnD3 + , ugnD4 + , ugnD5 + , ugnD6 ) = vecToTuple freeUgnDatas - (ugn0,fill0,ugnStable0,fillStats0) = unbundle ugnD0 - (ugn1,fill1,ugnStable1,fillStats1) = unbundle ugnD1 - (ugn2,fill2,ugnStable2,fillStats2) = unbundle ugnD2 - (ugn3,fill3,ugnStable3,fillStats3) = unbundle ugnD3 - (ugn4,fill4,ugnStable4,fillStats4) = unbundle ugnD4 - (ugn5,fill5,ugnStable5,fillStats5) = unbundle ugnD5 - (ugn6,fill6,ugnStable6,fillStats6) = unbundle ugnD6 + (ugn0, fill0, ugnStable0, fillStats0) = unbundle ugnD0 + (ugn1, fill1, ugnStable1, fillStats1) = unbundle ugnD1 + (ugn2, fill2, ugnStable2, fillStats2) = unbundle ugnD2 + (ugn3, fill3, ugnStable3, fillStats3) = unbundle ugnD3 + (ugn4, fill4, ugnStable4, fillStats4) = unbundle ugnD4 + (ugn5, fill5, ugnStable5, fillStats5) = unbundle ugnD5 + (ugn6, fill6, ugnStable6, fillStats6) = unbundle ugnD6 FillStats fillMin0 fillMax0 = unbundle fillStats0 FillStats fillMin1 fillMax1 = unbundle fillStats1 @@ -284,7 +313,8 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = FillStats fillMin5 fillMax5 = unbundle fillStats5 FillStats fillMin6 fillMax6 = unbundle fillStats6 - allReady = trueFor (SNat @(Milliseconds 500)) sysClk syncRst (and <$> bundle transceivers.linkReadys) + allReady = + trueFor (SNat @(Milliseconds 500)) sysClk syncRst (and <$> bundle transceivers.linkReadys) transceiversFailedAfterUp = sticky sysClk syncRst (isFalling sysClk syncRst enableGen False allReady) @@ -294,23 +324,36 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = -- Clock control clockControlReset = - orReset (unsafeFromActiveLow allReady) - $ orReset (unsafeFromActiveHigh transceiversFailedAfterUp) - (unsafeFromActiveLow syncStart) + orReset (unsafeFromActiveLow allReady) + $ orReset + (unsafeFromActiveHigh transceiversFailedAfterUp) + (unsafeFromActiveLow syncStart) availableLinkMask = pure maxBound - (clockMod, stabilities, allStable0, _allCentered) = unbundle $ - fmap - (\CallistoResult{..} -> (maybeSpeedChange, stability, allStable, allSettled)) - callistoResult - (stability0, stability1, stability2, stability3, stability4, stability5, stability6 + (clockMod, stabilities, allStable0, _allCentered) = + unbundle + $ fmap + (\CallistoResult{..} -> (maybeSpeedChange, stability, allStable, allSettled)) + callistoResult + ( stability0 + , stability1 + , stability2 + , stability3 + , stability4 + , stability5 + , stability6 ) = vecToTuple $ unbundle stabilities callistoResult = callistoClockControlWithIla @LinkCount @CccBufferSize - (head transceivers.txClocks) sysClk clockControlReset clockControlConfig - IlaControl{..} availableLinkMask (fmap (fmap resize) domainDiffs) + (head transceivers.txClocks) + sysClk + clockControlReset + clockControlConfig + IlaControl{..} + availableLinkMask + (fmap (fmap resize) domainDiffs) -- Capture every 100 microseconds - this should give us a window of about 5 -- seconds. Or: when we're in reset. If we don't do the latter, the VCDs get @@ -318,129 +361,234 @@ fullMeshHwTest refClk sysClk IlaControl{syncRst = rst, ..} rxNs rxPs miso = capture = (captureFlag .&&. allReady) .||. unsafeToActiveHigh syncRst fincFdecIla :: Signal Basic125 () - fincFdecIla = setName @"fincFdecIla" $ ila - (ilaConfig $ - "trigger_0" - :> "capture_0" - :> "probe_milliseconds" - :> "probe_allStable0" - :> "probe_allStable1" - :> "probe_transceiversFailedAfterUp" - :> "probe_nFincs" - :> "probe_nFdecs" - :> "probe_net_nFincs" - :> "probe_ugn0" :> "probe_ugn1" :> "probe_ugn2" :> "probe_ugn3" :> "probe_ugn4" :> "probe_ugn5" :> "probe_ugn6" - :> "probe_fill0" :> "probe_fill2" :> "probe_fill1" :> "probe_fill3" :> "probe_fill4" :> "probe_fill5" :> "probe_fill6" - :> "probe_fillMin0" :> "probe_fillMin2" :> "probe_fillMin1" :> "probe_fillMin3" :> "probe_fillMin4" :> "probe_fillMin5" :> "probe_fillMin6" - :> "probe_fillMax0" :> "probe_fillMax2" :> "probe_fillMax1" :> "probe_fillMax3" :> "probe_fillMax4" :> "probe_fillMax5" :> "probe_fillMax6" - :> "stability0" :> "stability2" :> "stability1" :> "stability3" :> "stability4" :> "stability5" :> "stability6" - :> "ugnStable0" :> "ugnStable1" :> "ugnStable2" :> "ugnStable3" :> "ugnStable4" :> "ugnStable5" :> "ugnStable6" - :> "probe_linkReadys" - :> "probe_linkUps" - :> "fifoUnderflows" :> "fifoOverflows" - :> Nil - ){depth = D16384} - sysClk - - -- Trigger as soon as we come out of reset - (unsafeToActiveLow syncRst) - - capture - - -- Debug probes - milliseconds1 - allStable0 - allStable1 - transceiversFailedAfterUp - nFincs - nFdecs - (fmap unsignedToSigned nFincs - fmap unsignedToSigned nFdecs) - ugn0 ugn1 ugn2 ugn3 ugn4 ugn5 ugn6 - fill0 fill1 fill2 fill3 fill4 fill5 fill6 - fillMin0 fillMin1 fillMin2 fillMin3 fillMin4 fillMin5 fillMin6 - fillMax0 fillMax1 fillMax2 fillMax3 fillMax4 fillMax5 fillMax6 - stability0 stability1 stability2 stability3 stability4 stability5 stability6 - ugnStable0 ugnStable1 ugnStable2 ugnStable3 ugnStable4 ugnStable5 ugnStable6 - (bundle transceivers.linkReadys) - (bundle transceivers.linkUps) - ((pack . reverse) <$> bundle fifoUnderflowsFree) - ((pack . reverse) <$> bundle fifoOverflowsFree) - - captureFlag = riseEvery sysClk syncRst enableGen - (SNat @(PeriodToCycles Basic125 (Milliseconds 1))) - - nFincs = regEn sysClk clockControlReset enableGen - (0 :: Unsigned 32) - ((== Just SpeedUp) <$> clockMod) - (satSucc SatBound <$> nFincs) - - nFdecs = regEn sysClk clockControlReset enableGen - (0 :: Unsigned 32) - ((== Just SlowDown) <$> clockMod) - (satSucc SatBound <$> nFdecs) + fincFdecIla = + setName @"fincFdecIla" + $ ila + ( ilaConfig + $ "trigger_0" + :> "capture_0" + :> "probe_milliseconds" + :> "probe_allStable0" + :> "probe_allStable1" + :> "probe_transceiversFailedAfterUp" + :> "probe_nFincs" + :> "probe_nFdecs" + :> "probe_net_nFincs" + :> "probe_ugn0" + :> "probe_ugn1" + :> "probe_ugn2" + :> "probe_ugn3" + :> "probe_ugn4" + :> "probe_ugn5" + :> "probe_ugn6" + :> "probe_fill0" + :> "probe_fill2" + :> "probe_fill1" + :> "probe_fill3" + :> "probe_fill4" + :> "probe_fill5" + :> "probe_fill6" + :> "probe_fillMin0" + :> "probe_fillMin2" + :> "probe_fillMin1" + :> "probe_fillMin3" + :> "probe_fillMin4" + :> "probe_fillMin5" + :> "probe_fillMin6" + :> "probe_fillMax0" + :> "probe_fillMax2" + :> "probe_fillMax1" + :> "probe_fillMax3" + :> "probe_fillMax4" + :> "probe_fillMax5" + :> "probe_fillMax6" + :> "stability0" + :> "stability2" + :> "stability1" + :> "stability3" + :> "stability4" + :> "stability5" + :> "stability6" + :> "ugnStable0" + :> "ugnStable1" + :> "ugnStable2" + :> "ugnStable3" + :> "ugnStable4" + :> "ugnStable5" + :> "ugnStable6" + :> "probe_linkReadys" + :> "probe_linkUps" + :> "fifoUnderflows" + :> "fifoOverflows" + :> Nil + ) + { depth = D16384 + } + sysClk + -- Trigger as soon as we come out of reset + (unsafeToActiveLow syncRst) + capture + -- Debug probes + milliseconds1 + allStable0 + allStable1 + transceiversFailedAfterUp + nFincs + nFdecs + (fmap unsignedToSigned nFincs - fmap unsignedToSigned nFdecs) + ugn0 + ugn1 + ugn2 + ugn3 + ugn4 + ugn5 + ugn6 + fill0 + fill1 + fill2 + fill3 + fill4 + fill5 + fill6 + fillMin0 + fillMin1 + fillMin2 + fillMin3 + fillMin4 + fillMin5 + fillMin6 + fillMax0 + fillMax1 + fillMax2 + fillMax3 + fillMax4 + fillMax5 + fillMax6 + stability0 + stability1 + stability2 + stability3 + stability4 + stability5 + stability6 + ugnStable0 + ugnStable1 + ugnStable2 + ugnStable3 + ugnStable4 + ugnStable5 + ugnStable6 + (bundle transceivers.linkReadys) + (bundle transceivers.linkUps) + ((pack . reverse) <$> bundle fifoUnderflowsFree) + ((pack . reverse) <$> bundle fifoOverflowsFree) + + captureFlag = + riseEvery + sysClk + syncRst + enableGen + (SNat @(PeriodToCycles Basic125 (Milliseconds 1))) + + nFincs = + regEn + sysClk + clockControlReset + enableGen + (0 :: Unsigned 32) + ((== Just SpeedUp) <$> clockMod) + (satSucc SatBound <$> nFincs) + + nFdecs = + regEn + sysClk + clockControlReset + enableGen + (0 :: Unsigned 32) + ((== Just SlowDown) <$> clockMod) + (satSucc SatBound <$> nFdecs) frequencyAdjustments :: Signal Basic125 (FINC, FDEC) frequencyAdjustments = - E.delay sysClk enableGen minBound {- glitch filter -} $ - withClockResetEnable sysClk clockControlReset enableGen $ - stickyBits @Basic125 d20 (speedChangeToPins . fromMaybe NoChange <$> clockMod) + E.delay sysClk enableGen minBound {- glitch filter -} + $ withClockResetEnable sysClk clockControlReset enableGen + $ stickyBits @Basic125 d20 (speedChangeToPins . fromMaybe NoChange <$> clockMod) domainDiffs = domainDiffCounterExt sysClk clockControlReset <$> transceivers.rxClocks <*> transceivers.txClocks --- | Tracks the min/max values of the input during the last milliseconds --- --- Updates once per millisecond. -fillStats :: forall dom a. (KnownDomain dom, Ord a, Num a, Bounded a, NFDataX a) => - Clock dom -> Reset dom -> - Signal dom a -> Signal dom (FillStats a) -fillStats clk rst = moore clk rst enableGen go (\(_,_,x) -> x) (maxBound, mempty, mempty) +{- | Tracks the min/max values of the input during the last milliseconds + +Updates once per millisecond. +-} +fillStats :: + forall dom a. + (KnownDomain dom, Ord a, Num a, Bounded a, NFDataX a) => + Clock dom -> + Reset dom -> + Signal dom a -> + Signal dom (FillStats a) +fillStats clk rst = moore clk rst enableGen go (\(_, _, x) -> x) (maxBound, mempty, mempty) where - go :: (IndexMs dom 1, FillStats a, FillStats a) -> a -> (IndexMs dom 1, FillStats a, FillStats a) + go :: + (IndexMs dom 1, FillStats a, FillStats a) -> + a -> + (IndexMs dom 1, FillStats a, FillStats a) go (cntr, prevStats, out) inp | cntr == 0 = (maxBound, mempty, new) | otherwise = (cntr - 1, new, out) where new = mappend prevStats (FillStats inp inp) -data FillStats a = FillStats { fillMin :: a, fillMax :: a } deriving (Generic, NFDataX, BitPack) +data FillStats a = FillStats {fillMin :: a, fillMax :: a} + deriving (Generic, NFDataX, BitPack) instance Bundle (FillStats a) where type Unbundled dom (FillStats a) = FillStats (Signal dom a) bundle (FillStats sigMin sigMax) = liftA2 FillStats sigMin sigMax - unbundle x = FillStats { fillMin = fmap fillMin x, fillMax = fmap fillMax x } + unbundle x = FillStats{fillMin = fmap fillMin x, fillMax = fmap fillMax x} -instance Ord a => Semigroup (FillStats a) where +instance (Ord a) => Semigroup (FillStats a) where a <> b = - FillStats { fillMin = min (fillMin a) (fillMin b) - , fillMax = max (fillMax a) (fillMax b) } + FillStats + { fillMin = min (fillMin a) (fillMin b) + , fillMax = max (fillMax a) (fillMax b) + } instance (Bounded a, Ord a) => Monoid (FillStats a) where - mempty = FillStats { fillMin=maxBound, fillMax=minBound } + mempty = FillStats{fillMin = maxBound, fillMax = minBound} --- | Counts how many cycles the input signal has been stable --- --- Stable means equal to its previous value according to the 'Eq' instance. --- The 'BitPack' instance is only used as a convenient way of intialization, --- it resets to a previous value of @unpack 0@. +{- | Counts how many cycles the input signal has been stable + +Stable means equal to its previous value according to the 'Eq' instance. +The 'BitPack' instance is only used as a convenient way of intialization, +it resets to a previous value of @unpack 0@. +-} stableFor :: forall n dom a. (KnownNat n, KnownDomain dom, Eq a, BitPack a, NFDataX a) => - Clock dom -> Reset dom -> Signal dom a -> Signal dom (Unsigned n) + Clock dom -> + Reset dom -> + Signal dom a -> + Signal dom (Unsigned n) stableFor clk rst = moore clk rst enableGen go snd (unpack 0, 0) where - go :: (a,Unsigned n) -> a -> (a,Unsigned n) - go (prev,cntr) inp + go :: (a, Unsigned n) -> a -> (a, Unsigned n) + go (prev, cntr) inp | inp == prev = (prev, satSucc SatBound cntr) - | otherwise = (inp, 0) + | otherwise = (inp, 0) -- | Wrapper around 'stableFor' that checks the input has been stable for atleast @ms@ milliseconds stableForMs :: forall ms dom a. (KnownNat ms, KnownDomain dom, Eq a, BitPack a, NFDataX a) => - SNat ms -> Clock dom -> Reset dom -> Signal dom a -> Signal dom Bool + SNat ms -> + Clock dom -> + Reset dom -> + Signal dom a -> + Signal dom Bool stableForMs SNat clk rst inp = liftA2 (>=) stable (snatToNum (SNat @(PeriodToCycles dom (Milliseconds ms)))) where @@ -456,27 +604,36 @@ fullMeshSwCcTest :: "MISO" ::: Signal Basic125 Bit -> ( "GTH_TX_NS" ::: TransceiverWires GthTxS LinkCount , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount - , "" ::: - ( "FINC" ::: Signal Basic125 Bool - , "FDEC" ::: Signal Basic125 Bool - ) + , "" + ::: ( "FINC" ::: Signal Basic125 Bool + , "FDEC" ::: Signal Basic125 Bool + ) , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) fullMeshSwCcTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, (riscvFinc, riscvFdec), syncOut, spiDone, spiOut) where refClk = ibufds_gte3 refClkDiff :: Clock Ext200 (sysClk, sysRst) = clockWizardDifferential sysClkDiff noReset - ilaControl@IlaControl{syncRst,syncOut,syncStart} = ilaPlotSetup IlaPlotSetup{..} - - ( txns, txps, _hwFincFdecs, _callistoResult, callistoReset - , dataCounts, _stats, spiDone, spiOut, transceiversFailedAfterUp, allReady + ilaControl@IlaControl{syncRst, syncOut, syncStart} = ilaPlotSetup IlaPlotSetup{..} + + ( txns + , txps + , _hwFincFdecs + , _callistoResult + , callistoReset + , dataCounts + , _stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady , allStable , ugnsStable ) = fullMeshHwTest refClk sysClk ilaControl rxns rxps miso @@ -484,13 +641,15 @@ fullMeshSwCcTest refClkDiff sysClkDiff syncIn rxns rxps miso = (riscvFinc, riscvFdec) = fullMeshRiscvTest sysClk callistoReset dataCounts - allUgnsStable = fmap and $ bundle ugnsStable -- checks that tests are not synchronously start before all -- transceivers are up - startBeforeAllReady = sticky sysClk syncRst - (syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) + startBeforeAllReady = + sticky + sysClk + syncRst + (syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) endSuccess :: Signal Basic125 Bool endSuccess = trueFor (SNat @(Seconds 5)) sysClk syncRst $ allStable .&&. allUgnsStable @@ -499,31 +658,34 @@ fullMeshSwCcTest refClkDiff sysClkDiff syncIn rxns rxps miso = startTest = hitlVioBool sysClk - -- done (endSuccess .||. transceiversFailedAfterUp .||. startBeforeAllReady) - -- success (allUgnsStable .&&. not <$> (transceiversFailedAfterUp .||. startBeforeAllReady)) + makeTopEntity 'fullMeshSwCcTest testsToRun :: Int testsToRun = 1 tests :: HitlTestsWithPostProcData () SimConf -tests = Map.fromList $ P.zip ["CC" <> fromString (show n) | n <- [0..testsToRun-1]] $ P.repeat - ( allFpgas () - , def { mTopologyType = Just $ Complete (natToInteger @FpgaCount) - , samples = 1000 - , duration = natToNum @(PeriodToCycles Basic125 (Seconds 60)) - , stabilityMargin = snatToNum cccStabilityCheckerMargin - , stabilityFrameSize = snatToNum cccStabilityCheckerFramesize - , reframe = cccEnableReframing - , rusty = cccEnableRustySimulation - , waitTime = fromEnum cccReframingWaitTime - , clockOffsets = toList $ repeat @FpgaCount 0 - , startupDelays = toList $ repeat @FpgaCount 0 - } - ) +tests = + Map.fromList + $ P.zip ["CC" <> fromString (show n) | n <- [0 .. testsToRun - 1]] + $ P.repeat + ( allFpgas () + , def + { mTopologyType = Just $ Complete (natToInteger @FpgaCount) + , samples = 1000 + , duration = natToNum @(PeriodToCycles Basic125 (Seconds 60)) + , stabilityMargin = snatToNum cccStabilityCheckerMargin + , stabilityFrameSize = snatToNum cccStabilityCheckerFramesize + , reframe = cccEnableReframing + , rusty = cccEnableRustySimulation + , waitTime = fromEnum cccReframingWaitTime + , clockOffsets = toList $ repeat @FpgaCount 0 + , startupDelays = toList $ repeat @FpgaCount 0 + } + ) where ClockControlConfig{..} = clockControlConfig diff --git a/bittide-instances/src/Bittide/Instances/Hitl/HwCcTopologies.hs b/bittide-instances/src/Bittide/Instances/Hitl/HwCcTopologies.hs index d87cb4dad..fd9b7eace 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/HwCcTopologies.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/HwCcTopologies.hs @@ -7,35 +7,34 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} +{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} --- | Test whether clock boards are configurable and transceiver links come --- online. If they do, run clock control and wait for the clocks to stabilize. --- Also see 'Bittide.Instances.Hitl.Setup'. It has two tricks up its --- sleeve: --- --- 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming --- its clock boards at the same time. --- --- 2. It keeps track of how many times the GTH's reset manager had to reset --- the connection and how often it lost connections after establishing --- them. --- --- This test will succeed if all clocks have been stable for 5 seconds. Note: --- this doesn't test reframing yet. --- -module Bittide.Instances.Hitl.HwCcTopologies - ( hwCcTopologyWithRiscvTest - , hwCcTopologyTest - , clockControlConfig - , tests - ) where +{- | Test whether clock boards are configurable and transceiver links come +online. If they do, run clock control and wait for the clocks to stabilize. +Also see 'Bittide.Instances.Hitl.Setup'. It has two tricks up its +sleeve: + + 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming + its clock boards at the same time. + + 2. It keeps track of how many times the GTH's reset manager had to reset + the connection and how often it lost connections after establishing + them. + +This test will succeed if all clocks have been stable for 5 seconds. Note: +this doesn't test reframing yet. +-} +module Bittide.Instances.Hitl.HwCcTopologies ( + hwCcTopologyWithRiscvTest, + hwCcTopologyTest, + clockControlConfig, + tests, +) where -import Clash.Prelude (withClockResetEnable) import Clash.Explicit.Prelude hiding (PeriodToCycles) import qualified Clash.Explicit.Prelude as E +import Clash.Prelude (withClockResetEnable) import Data.Bifunctor (bimap) import Data.Maybe (fromMaybe, isJust) @@ -48,25 +47,27 @@ import System.FilePath import Bittide.Arithmetic.Time import Bittide.ClockControl import Bittide.ClockControl.Callisto -import Bittide.ClockControl.Callisto.Util (FINC, FDEC, stickyBits, speedChangeToPins) +import Bittide.ClockControl.Callisto.Util (FDEC, FINC, speedChangeToPins, stickyBits) import Bittide.ClockControl.Registers (clockControlWb) import Bittide.ClockControl.Si5395J -import Bittide.ClockControl.Si539xSpi (ConfigState(Error, Finished), si539xSpi) -import Bittide.DoubleBufferedRam - ( InitialContent(Reloadable), ContentType(Blob), RegisterWritePriority(CircuitPriority) - , registerWb - ) +import Bittide.ClockControl.Si539xSpi (ConfigState (Error, Finished), si539xSpi) import Bittide.Counter +import Bittide.DoubleBufferedRam ( + ContentType (Blob), + InitialContent (Reloadable), + RegisterWritePriority (CircuitPriority), + registerWb, + ) import Bittide.ElasticBuffer (sticky) import Bittide.Instances.Domains -import Bittide.ProcessingElement (PeConfig(..), processingElement) +import Bittide.ProcessingElement (PeConfig (..), processingElement) import Bittide.ProcessingElement.Util (memBlobsFromElf) -import Bittide.SharedTypes (Bytes, ByteOrder(BigEndian)) -import Bittide.Simulate.Config (SimConf(..)) +import Bittide.SharedTypes (ByteOrder (BigEndian), Bytes) +import Bittide.Simulate.Config (SimConf (..)) import Bittide.Topology import Bittide.Transceiver (transceiverPrbsN) -import Bittide.Hitl (HitlTestsWithPostProcData, TestName, Probes, hitlVio) +import Bittide.Hitl (HitlTestsWithPostProcData, Probes, TestName, hitlVio) import Bittide.Instances.Hitl.IlaPlot import Bittide.Instances.Hitl.Setup @@ -75,7 +76,7 @@ import Project.FilePath import Clash.Annotations.TH (makeTopEntity) import Clash.Class.Counter import Clash.Cores.Xilinx.GTH -import Clash.Cores.Xilinx.Ila (IlaConfig(..), Depth(..), ila, ilaConfig) +import Clash.Cores.Xilinx.Ila (Depth (..), IlaConfig (..), ila, ilaConfig) import Clash.Sized.Extra (unsignedToSigned) import Clash.Xilinx.ClockGen @@ -89,90 +90,100 @@ import qualified Data.Map.Strict as Map (fromList) type AllStablePeriod = Seconds 5 --- | The number of FINCs (if positive) or FDECs (if negative) applied --- prior to the test start leading to some desired initial clock --- offset. --- --- Note that the value is limited to fit within 16 bits right now to --- avoid the generation of YAML files with integers that are larger --- than 63 bits. +{- | The number of FINCs (if positive) or FDECs (if negative) applied +prior to the test start leading to some desired initial clock +offset. + +Note that the value is limited to fit within 16 bits right now to +avoid the generation of YAML files with integers that are larger +than 63 bits. +-} type InitialClockShift = Signed 32 --- | The number of clock cycles to wait before starting clock control --- according to the local, but stable system clock of a node. +{- | The number of clock cycles to wait before starting clock control +according to the local, but stable system clock of a node. +-} type StartupDelay = Unsigned 32 -- | Availabe step size configurations. -data StepSizeSelect = - PPB_1 | PPB_10 | PPB_100 | PPM_1 +data StepSizeSelect + = PPB_1 + | PPB_10 + | PPB_100 + | PPM_1 deriving (Generic, NFDataX, BitPack, Eq, Enum, Bounded) -- | Calibration stages -data CCCalibrationStage = - NoCCCalibration | CCCalibrate | CCCalibrationValidation +data CCCalibrationStage + = NoCCCalibration + | CCCalibrate + | CCCalibrationValidation deriving (Generic, NFDataX, BitPack, Eq, Enum, Bounded) --- | The step size, as it is used by all tests. Note that changing the --- step size for individual tests requires recalibration of the clock --- offsets, which is why we fix it to a single and common value here. +{- | The step size, as it is used by all tests. Note that changing the +step size for individual tests requires recalibration of the clock +offsets, which is why we fix it to a single and common value here. +-} commonStepSizeSelect :: StepSizeSelect commonStepSizeSelect = PPB_10 --- | Accepted noise between the inital clock control calibration run --- and the last calibration verifiction run. +{- | Accepted noise between the inital clock control calibration run +and the last calibration verifiction run. +-} acceptableNoiseLevel :: InitialClockShift acceptableNoiseLevel = 6 disabled :: TestConfig -disabled = TestConfig - { fpgaEnabled = False - , calibrate = NoCCCalibration - , stepSizeSelect = commonStepSizeSelect - , initialClockShift = 0 - , startupDelay = 0 - , mask = 0 - } - --- | The test configuration. -data TestConfig = +disabled = TestConfig - { fpgaEnabled :: Bool - -- ^ Enables or disables an FPGA depending on the selected - -- topology. Disabled FPGAs immediediatly succeed after the test - -- start. - -- - -- Also note that the flag only disables clock control, while - -- other functionality, as for example SYNC_IN/SYNC_OUT time - -- synchronization, needs to stay alive. - , calibrate :: CCCalibrationStage - -- ^ Indicates the selected calibration stage. - , stepSizeSelect :: StepSizeSelect - -- ^ The selected step size of the test. Note that changing the - -- step size between tests requires re-calibration of the device - -- based inital clock shift. - , initialClockShift :: InitialClockShift - -- ^ Some artificical clock shift applied prior to the test - -- start. The shift is given in FINCs (if positive) or FDECs (if - -- negative) and, thus, depdends on 'stepSizeSelect'. - , startupDelay :: StartupDelay - -- ^ Some intial startup delay given in the number of clock - -- cycles of the stable clock. - , mask :: BitVector LinkCount - -- ^ The link mask depending on the selected topology. + { fpgaEnabled = False + , calibrate = NoCCCalibration + , stepSizeSelect = commonStepSizeSelect + , initialClockShift = 0 + , startupDelay = 0 + , mask = 0 } + +-- | The test configuration. +data TestConfig = TestConfig + { fpgaEnabled :: Bool + -- ^ Enables or disables an FPGA depending on the selected + -- topology. Disabled FPGAs immediediatly succeed after the test + -- start. + -- + -- Also note that the flag only disables clock control, while + -- other functionality, as for example SYNC_IN/SYNC_OUT time + -- synchronization, needs to stay alive. + , calibrate :: CCCalibrationStage + -- ^ Indicates the selected calibration stage. + , stepSizeSelect :: StepSizeSelect + -- ^ The selected step size of the test. Note that changing the + -- step size between tests requires re-calibration of the device + -- based inital clock shift. + , initialClockShift :: InitialClockShift + -- ^ Some artificical clock shift applied prior to the test + -- start. The shift is given in FINCs (if positive) or FDECs (if + -- negative) and, thus, depdends on 'stepSizeSelect'. + , startupDelay :: StartupDelay + -- ^ Some intial startup delay given in the number of clock + -- cycles of the stable clock. + , mask :: BitVector LinkCount + -- ^ The link mask depending on the selected topology. + } deriving (Generic, NFDataX, BitPack) clockControlConfig :: - $(case (instancesClockConfig (Proxy @Basic125)) of { (_ :: t) -> liftTypeQ @t }) + $(case (instancesClockConfig (Proxy @Basic125)) of (_ :: t) -> liftTypeQ @t) clockControlConfig = $(lift (instancesClockConfig (Proxy @Basic125))) --- | Instantiates a RiscV core that copies instructions coming from a hardware --- implementation of Callisto (see 'topologyTest') and copies it to a register --- tied to FINC/FDEC. +{- | Instantiates a RiscV core that copies instructions coming from a hardware +implementation of Callisto (see 'topologyTest') and copies it to a register +tied to FINC/FDEC. +-} riscvCopyTest :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => Clock dom -> Reset dom -> Signal dom (CallistoResult LinkCount) -> @@ -183,17 +194,22 @@ riscvCopyTest :: ) riscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec where - (_, fIncDec) = toSignals - ( circuit $ \jtag -> do - [wbA, wbB] <- withClockResetEnable clk rst enableGen $ processingElement @dom peConfig -< jtag - fIncDecCallisto -< wbA - (fIncDec, _allStable) <- withClockResetEnable clk rst enableGen $ - clockControlWb margin framesize (pure $ complement 0) dataCounts -< wbB - idC -< fIncDec - ) (pure $ JtagIn low low low, pure ()) + (_, fIncDec) = + toSignals + ( circuit $ \jtag -> do + [wbA, wbB] <- + withClockResetEnable clk rst enableGen $ processingElement @dom peConfig -< jtag + fIncDecCallisto -< wbA + (fIncDec, _allStable) <- + withClockResetEnable clk rst enableGen + $ clockControlWb margin framesize (pure $ complement 0) dataCounts + -< wbB + idC -< fIncDec + ) + (pure $ JtagIn low low low, pure ()) fIncDecCallisto :: - forall aw nBytes . + forall aw nBytes. (KnownNat aw, 2 <= aw, nBytes ~ 4) => Circuit (Wishbone dom 'Standard aw (Bytes nBytes)) @@ -202,12 +218,13 @@ riscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec where goFIncDecCallisto (wbM2S, _) = (wbS2M, ()) where - (_, wbS2M) = withClockResetEnable clk rst enableGen $ - registerWb - CircuitPriority - (0 :: Bytes nBytes, 0 :: Bytes nBytes) - wbM2S - (fmap (fmap ((,0) . extend . pack)) fincfdec) + (_, wbS2M) = + withClockResetEnable clk rst enableGen + $ registerWb + CircuitPriority + (0 :: Bytes nBytes, 0 :: Bytes nBytes) + wbM2S + (fmap (fmap ((,0) . extend . pack)) fincfdec) fincfdec :: Signal dom (Maybe SpeedChange) fincfdec = @@ -219,20 +236,22 @@ riscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec -- this doesn't happen). This makes sure the RiscV doesn't read the same -- result from the hardware clock control twice. clearOnAck :: ("ACK" ::: Bool) -> Maybe SpeedChange -> Maybe SpeedChange - clearOnAck False maybeSpeedChange = maybeSpeedChange - clearOnAck True (Just speedChange) = Just speedChange - clearOnAck True Nothing = Just NoChange + clearOnAck False maybeSpeedChange = maybeSpeedChange + clearOnAck True (Just speedChange) = Just speedChange + clearOnAck True Nothing = Just NoChange margin = d2 framesize = SNat @(PeriodToCycles dom (Seconds 1)) - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release - elfPath = elfDir "clock-control-reg-cpy" - memBlobsFromElf BigEndian (Nothing, Nothing) elfPath Nothing) + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release + elfPath = elfDir "clock-control-reg-cpy" + memBlobsFromElf BigEndian (Nothing, Nothing) elfPath Nothing + ) {- 0b10xxxxx_xxxxxxxx 0b10 0x8x instruction memory @@ -246,9 +265,10 @@ riscvCopyTest clk rst callistoResult dataCounts = unbundle fIncDec (Reloadable $ Blob iMem) (Reloadable $ Blob dMem) --- | Instantiates a hardware implementation of Callisto and exports its results. Can --- be used to drive FINC/FDEC directly (see @FINC_FDEC@ result) or to tie the --- results to a RiscV core (see 'riscvCopyTest') +{- | Instantiates a hardware implementation of Callisto and exports its results. Can +be used to drive FINC/FDEC directly (see @FINC_FDEC@ result) or to tie the +results to a RiscV core (see 'riscvCopyTest') +-} topologyTest :: "SMA_MGT_REFCLK_C" ::: Clock Ext200 -> "SYSCLK" ::: Clock Basic125 -> @@ -266,52 +286,52 @@ topologyTest :: , "DATA_COUNTERS" ::: Vec LinkCount (Signal Basic125 (RelDataCount 32)) , "stats" ::: Vec LinkCount (Signal Basic125 ResetManager.Statistics) , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) , "transceiversFailedAfterUp" ::: Signal Basic125 Bool , "ALL_READY" ::: Signal Basic125 Bool - , "ALL_STABLE" ::: Signal Basic125 Bool + , "ALL_STABLE" ::: Signal Basic125 Bool , "CALIB_I" ::: Signal Basic125 InitialClockShift , "CALIB_E" ::: Signal Basic125 InitialClockShift ) -topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso cfg - = fincFdecIla `hwSeqX` - ( transceivers.txNs - , transceivers.txPs - , frequencyAdjustments - , callistoResult - , clockControlReset - , domainDiffs - , transceivers.stats - , spiDone - , spiOut - , transceiversFailedAfterUp - , allReady - , allStable0 - , calibratedClockShift - , validationClockShift - ) +topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso cfg = + fincFdecIla + `hwSeqX` ( transceivers.txNs + , transceivers.txPs + , frequencyAdjustments + , callistoResult + , clockControlReset + , domainDiffs + , transceivers.stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable0 + , calibratedClockShift + , validationClockShift + ) where syncRst = rst `orReset` unsafeFromActiveHigh spiErr -- Clock board programming - spiDone = E.dflipflop sysClk $ (==Finished) <$> spiState + spiDone = E.dflipflop sysClk $ (== Finished) <$> spiState spiErr = E.dflipflop sysClk $ isErr <$> spiState isErr (Error _) = True - isErr _ = False + isErr _ = False (_, _, spiState, spiOut) = let selectConfig = \case - PPB_1 -> testConfig6_200_on_0a_1ppb - PPB_10 -> testConfig6_200_on_0a_10ppb + PPB_1 -> testConfig6_200_on_0a_1ppb + PPB_10 -> testConfig6_200_on_0a_10ppb PPB_100 -> testConfig6_200_on_0a_100ppb - PPM_1 -> testConfig6_200_on_0a_1ppm + PPM_1 -> testConfig6_200_on_0a_1ppm -- TODO: create some generic method for generating this, which -- does not rely on template haskell @@ -323,15 +343,18 @@ topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso c rsts = orReset syncRst . unsafeFromActiveLow <$> optionMask -- only the reset and the selected configuration differ according to -- 'stepSizeSelect' - si539xSpi# r c = withClockResetEnable sysClk r enableGen - $ si539xSpi c (SNat @(Microseconds 10)) (pure Nothing) miso + si539xSpi# r c = + withClockResetEnable sysClk r enableGen + $ si539xSpi c (SNat @(Microseconds 10)) (pure Nothing) miso -- create an SPI interface for each of the supported configurations spis = si539xSpi# <$> rsts <*> (selectConfig <$> cfgOptions) - in - (\(a,b,c,d) -> (a,b,c,unbundle d)) . unbundle - $ (!!) <$> bundle ((\(a,b,c,d) -> bundle (a,b,c,bundle d)) <$> spis) - -- mux the selected interface according to 'stepSizeSelect' - <*> (stepSizeSelect <$> cfg) + in + (\(a, b, c, d) -> (a, b, c, unbundle d)) + . unbundle + $ (!!) + <$> bundle ((\(a, b, c, d) -> bundle (a, b, c, bundle d)) <$> spis) + -- mux the selected interface according to 'stepSizeSelect' + <*> (stepSizeSelect <$> cfg) -- Transceiver setup @@ -339,7 +362,12 @@ topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso c transceivers = transceiverPrbsN - @GthTx @GthRx @Ext200 @Basic125 @GthTxS @GthRxS + @GthTx + @GthRx + @Ext200 + @Basic125 + @GthTxS + @GthRxS Transceiver.defConfig Transceiver.Inputs { clock = sysClk @@ -354,7 +382,8 @@ topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso c , rxReadys = repeat (pure True) } - allReady = trueFor (SNat @(Milliseconds 500)) sysClk syncRst (and <$> bundle transceivers.linkReadys) + allReady = + trueFor (SNat @(Milliseconds 500)) sysClk syncRst (and <$> bundle transceivers.linkReadys) transceiversFailedAfterUp = sticky sysClk syncRst (isFalling sysClk syncRst enableGen False allReady) @@ -365,30 +394,39 @@ topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso c -- Startup delay startupDelayRst = - orReset (unsafeFromActiveLow clocksAdjusted) - $ orReset (unsafeFromActiveLow allReady) - $ orReset (unsafeFromActiveHigh transceiversFailedAfterUp) - (unsafeFromActiveLow syncStart) - - delayCount = register sysClk startupDelayRst enableGen (0 :: StartupDelay) - $ (\c s -> if c < s then satSucc SatBound c else c) - <$> delayCount - <*> (startupDelay <$> cfg) + orReset (unsafeFromActiveLow clocksAdjusted) + $ orReset (unsafeFromActiveLow allReady) + $ orReset + (unsafeFromActiveHigh transceiversFailedAfterUp) + (unsafeFromActiveLow syncStart) + + delayCount = + register sysClk startupDelayRst enableGen (0 :: StartupDelay) + $ (\c s -> if c < s then satSucc SatBound c else c) + <$> delayCount + <*> (startupDelay <$> cfg) -- Clock control - clockControlReset = startupDelayRst `orReset` - unsafeFromActiveLow ((==) <$> delayCount <*> (startupDelay <$> cfg)) + clockControlReset = + startupDelayRst + `orReset` unsafeFromActiveLow ((==) <$> delayCount <*> (startupDelay <$> cfg)) - (clockMod, _stabilities, allStable0, _allCentered) = unbundle $ - fmap - (\CallistoResult{..} -> (maybeSpeedChange, stability, allStable, allSettled)) - callistoResult + (clockMod, _stabilities, allStable0, _allCentered) = + unbundle + $ fmap + (\CallistoResult{..} -> (maybeSpeedChange, stability, allStable, allSettled)) + callistoResult callistoResult = callistoClockControlWithIla @LinkCount @CccBufferSize - (head transceivers.txClocks) sysClk clockControlReset clockControlConfig - IlaControl{..} (mask <$> cfg) (fmap (fmap resize) domainDiffs) + (head transceivers.txClocks) + sysClk + clockControlReset + clockControlConfig + IlaControl{..} + (mask <$> cfg) + (fmap (fmap resize) domainDiffs) -- Capture every 100 microseconds - this should give us a window of about 5 -- seconds. Or: when we're in reset. If we don't do the latter, the VCDs get @@ -396,104 +434,147 @@ topologyTest refClk sysClk sysRst IlaControl{syncRst = rst, ..} rxNs rxPs miso c capture = (captureFlag .&&. allReady) .||. unsafeToActiveHigh syncRst fincFdecIla :: Signal Basic125 () - fincFdecIla = setName @"fincFdecIla" ila - (ilaConfig $ - "trigger_0" - :> "capture_0" - :> "probe_milliseconds" - :> "probe_allStable0" - :> "probe_transceiversFailedAfterUp" - :> "probe_nFincs" - :> "probe_nFdecs" - :> "probe_net_nFincs" - :> Nil - ){depth = D16384} - sysClk - - -- Trigger as soon as we come out of reset - (unsafeToActiveLow syncRst) - - capture - - -- Debug probes - milliseconds1 - allStable0 - transceiversFailedAfterUp - nFincs - nFdecs - (fmap unsignedToSigned nFincs - fmap unsignedToSigned nFdecs) - - captureFlag = riseEvery sysClk syncRst enableGen - (SNat @(PeriodToCycles Basic125 (Milliseconds 1))) - - nFincs = regEn sysClk clockControlReset enableGen - (0 :: Unsigned 32) - ((== Just SpeedUp) <$> clockMod) - (satSucc SatBound <$> nFincs) - - nFdecs = regEn sysClk clockControlReset enableGen - (0 :: Unsigned 32) - ((== Just SlowDown) <$> clockMod) - (satSucc SatBound <$> nFdecs) + fincFdecIla = + setName @"fincFdecIla" + ila + ( ilaConfig + $ "trigger_0" + :> "capture_0" + :> "probe_milliseconds" + :> "probe_allStable0" + :> "probe_transceiversFailedAfterUp" + :> "probe_nFincs" + :> "probe_nFdecs" + :> "probe_net_nFincs" + :> Nil + ) + { depth = D16384 + } + sysClk + -- Trigger as soon as we come out of reset + (unsafeToActiveLow syncRst) + capture + -- Debug probes + milliseconds1 + allStable0 + transceiversFailedAfterUp + nFincs + nFdecs + (fmap unsignedToSigned nFincs - fmap unsignedToSigned nFdecs) + + captureFlag = + riseEvery + sysClk + syncRst + enableGen + (SNat @(PeriodToCycles Basic125 (Milliseconds 1))) + + nFincs = + regEn + sysClk + clockControlReset + enableGen + (0 :: Unsigned 32) + ((== Just SpeedUp) <$> clockMod) + (satSucc SatBound <$> nFincs) + + nFdecs = + regEn + sysClk + clockControlReset + enableGen + (0 :: Unsigned 32) + ((== Just SlowDown) <$> clockMod) + (satSucc SatBound <$> nFdecs) -- Clock calibration clockShiftUpd = \case - Just SpeedUp -> satSucc SatBound + Just SpeedUp -> satSucc SatBound Just SlowDown -> satPred SatBound _ -> id notInCCReset = unsafeToActiveLow clockControlReset - clockShift = regEn sysClk sysRst enableGen - (0 :: InitialClockShift) - (notInCCReset .&&. (== CCCalibrate) . calibrate <$> cfg) - (clockShiftUpd <$> clockMod <*> clockShift) - - calibratedClockShift = register sysClk sysRst enableGen 0 $ - mux ( isFalling sysClk sysRst enableGen False - $ (== CCCalibrate) . calibrate <$> cfg + clockShift = + regEn + sysClk + sysRst + enableGen + (0 :: InitialClockShift) + (notInCCReset .&&. (== CCCalibrate) . calibrate <$> cfg) + (clockShiftUpd <$> clockMod <*> clockShift) + + calibratedClockShift = + register sysClk sysRst enableGen 0 + $ mux + ( isFalling sysClk sysRst enableGen False + $ (== CCCalibrate) + . calibrate + <$> cfg ) - clockShift - calibratedClockShift + clockShift + calibratedClockShift - validationClockShift = regEn sysClk sysRst enableGen - (0 :: InitialClockShift) - (notInCCReset .&&. (== CCCalibrationValidation) . calibrate <$> cfg) - (clockShiftUpd <$> clockMod <*> validationClockShift) + validationClockShift = + regEn + sysClk + sysRst + enableGen + (0 :: InitialClockShift) + (notInCCReset .&&. (== CCCalibrationValidation) . calibrate <$> cfg) + (clockShiftUpd <$> clockMod <*> validationClockShift) -- Initial Clock adjustment -- without the additional delay of 1 second here, some of the -- initial FINC/FDECs prior to test start will be lost. adjustStart = trueFor (SNat @(Seconds 1)) sysClk syncRst spiDone - clocksAdjusted = spiDone - .&&. ( (/= NoCCCalibration) . calibrate <$> cfg - .||. (==) <$> initialAdjust <*> adjustCount - ) + clocksAdjusted = + spiDone + .&&. ( (/= NoCCCalibration) + . calibrate + <$> cfg + .||. (==) + <$> initialAdjust + <*> adjustCount + ) adjusting = adjustStart .&&. (not <$> clocksAdjusted) adjustRst = unsafeFromActiveLow adjustStart initialAdjust = (+) <$> calibratedClockShift <*> (initialClockShift <$> cfg) - adjustCount = regEn sysClk adjustRst enableGen (0 :: InitialClockShift) - adjusting $ flip upd <$> adjustCount + adjustCount = + regEn + sysClk + adjustRst + enableGen + (0 :: InitialClockShift) + adjusting + $ flip upd + <$> adjustCount <*> let f = isFalling sysClk adjustRst enableGen False in bundle $ bimap f f $ unbundle frequencyAdjustments where upd (True, _) = satSucc SatBound upd (_, True) = satPred SatBound - upd _ = id + upd _ = id frequencyAdjustments :: Signal Basic125 (FINC, FDEC) - frequencyAdjustments = E.delay sysClk enableGen minBound {- glitch filter -} - $ mux adjusting + frequencyAdjustments = + E.delay sysClk enableGen minBound {- glitch filter -} + $ mux + adjusting ( speedChangeToFincFdec sysClk adjustRst - $ opSelect <$> initialAdjust <*> adjustCount + $ opSelect + <$> initialAdjust + <*> adjustCount ) ( withClockResetEnable sysClk clockControlReset enableGen - $ stickyBits @Basic125 d20 - $ speedChangeToPins . fromMaybe NoChange <$> clockMod + $ stickyBits @Basic125 d20 + $ speedChangeToPins + . fromMaybe NoChange + <$> clockMod ) where opSelect calib adjust = case compare calib adjust of @@ -516,17 +597,17 @@ hwCcTopologyWithRiscvTest :: "MISO" ::: Signal Basic125 Bit -> ( "GTH_TX_NS" ::: TransceiverWires GthTxS LinkCount , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount - , "" ::: - ( "FINC" ::: Signal Basic125 Bool - , "FDEC" ::: Signal Basic125 Bool - ) + , "" + ::: ( "FINC" ::: Signal Basic125 Bool + , "FDEC" ::: Signal Basic125 Bool + ) , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) hwCcTopologyWithRiscvTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, (riscvFinc, riscvFdec), syncOut, spiDone, spiOut) @@ -540,37 +621,70 @@ hwCcTopologyWithRiscvTest refClkDiff sysClkDiff syncIn rxns rxps miso = cfg = fromMaybe disabled <$> testConfig - ( txns, txps, hwFincFdecs, callistoResult, callistoReset - , dataCounts, _stats, spiDone, spiOut, transceiversFailedAfterUp, allReady - , allStable, calibI, calibE - ) = topologyTest refClk sysClk sysRst - ilaControl { skipTest = skip } - rxns rxps miso cfg - - (riscvFinc, riscvFdec) = unbundle - $ mux (unsafeToActiveHigh callistoReset) hwFincFdecs $ bundle - $ riscvCopyTest sysClk callistoReset callistoResult dataCounts + ( txns + , txps + , hwFincFdecs + , callistoResult + , callistoReset + , dataCounts + , _stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable + , calibI + , calibE + ) = + topologyTest + refClk + sysClk + sysRst + ilaControl{skipTest = skip} + rxns + rxps + miso + cfg + + (riscvFinc, riscvFdec) = + unbundle + $ mux (unsafeToActiveHigh callistoReset) hwFincFdecs + $ bundle + $ riscvCopyTest sysClk callistoReset callistoResult dataCounts -- check that tests are not synchronously start before all -- transceivers are up - startBeforeAllReady = sticky sysClk syncRst - (startTest .&&. syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) + startBeforeAllReady = + sticky + sysClk + syncRst + (startTest .&&. syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) endSuccess :: Signal Basic125 Bool - endSuccess = trueFor (SNat @AllStablePeriod) sysClk syncRst allStable - .&&. ( (/= CCCalibrationValidation) . calibrate <$> cfg - .||. (\i e -> abs (i - e) < acceptableNoiseLevel) <$> calibI <*> calibE - ) + endSuccess = + trueFor (SNat @AllStablePeriod) sysClk syncRst allStable + .&&. ( (/= CCCalibrationValidation) + . calibrate + <$> cfg + .||. (\i e -> abs (i - e) < acceptableNoiseLevel) + <$> calibI + <*> calibE + ) done = endSuccess .||. transceiversFailedAfterUp .||. startBeforeAllReady success = not <$> (transceiversFailedAfterUp .||. startBeforeAllReady) skip = - register sysClk sysRst enableGen False + register + sysClk + sysRst + enableGen + False (maybe False (not . fpgaEnabled) <$> testConfig) testConfig :: Signal Basic125 (Maybe TestConfig) testConfig = hitlVio disabled sysClk done success + makeTopEntity 'hwCcTopologyWithRiscvTest -- | Top entity for this test. See module documentation for more information. @@ -583,17 +697,17 @@ hwCcTopologyTest :: "MISO" ::: Signal Basic125 Bit -> ( "GTH_TX_NS" ::: TransceiverWires GthTxS LinkCount , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount - , "" ::: - ( "FINC" ::: Signal Basic125 Bool - , "FDEC" ::: Signal Basic125 Bool - ) + , "" + ::: ( "FINC" ::: Signal Basic125 Bool + , "FDEC" ::: Signal Basic125 Bool + ) , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) hwCcTopologyTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, unbundle hwFincFdecs, syncOut, spiDone, spiOut) @@ -605,23 +719,49 @@ hwCcTopologyTest refClkDiff sysClkDiff syncIn rxns rxps miso = cfg = fromMaybe disabled <$> testConfig - ( txns, txps, hwFincFdecs, _callistoResult, _callistoReset - , _dataCounts, _stats, spiDone, spiOut, transceiversFailedAfterUp, allReady - , allStable, calibI, calibE - ) = topologyTest refClk sysClk sysRst - ilaControl { skipTest = skip } - rxns rxps miso cfg + ( txns + , txps + , hwFincFdecs + , _callistoResult + , _callistoReset + , _dataCounts + , _stats + , spiDone + , spiOut + , transceiversFailedAfterUp + , allReady + , allStable + , calibI + , calibE + ) = + topologyTest + refClk + sysClk + sysRst + ilaControl{skipTest = skip} + rxns + rxps + miso + cfg -- check that tests are not synchronously start before all -- transceivers are up - startBeforeAllReady = sticky sysClk syncRst - (syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) + startBeforeAllReady = + sticky + sysClk + syncRst + (syncStart .&&. ((not <$> allReady) .||. transceiversFailedAfterUp)) endSuccess :: Signal Basic125 Bool - endSuccess = trueFor (SNat @(Seconds 5)) sysClk syncRst allStable - .&&. ( (/= CCCalibrationValidation) . calibrate <$> cfg - .||. (\i e -> abs (i - e) < acceptableNoiseLevel) <$> calibI <*> calibE - ) + endSuccess = + trueFor (SNat @(Seconds 5)) sysClk syncRst allStable + .&&. ( (/= CCCalibrationValidation) + . calibrate + <$> cfg + .||. (\i e -> abs (i - e) < acceptableNoiseLevel) + <$> calibI + <*> calibE + ) skip = maybe False (not . fpgaEnabled) <$> testConfig @@ -631,100 +771,107 @@ hwCcTopologyTest refClkDiff sysClkDiff syncIn rxns rxps miso = disabled sysClk -- done - (startTest .&&. - (skip .||. endSuccess .||. transceiversFailedAfterUp .||. startBeforeAllReady)) + ( startTest + .&&. (skip .||. endSuccess .||. transceiversFailedAfterUp .||. startBeforeAllReady) + ) -- success - (skip .||. - (allStable .&&. (not <$> (transceiversFailedAfterUp .||. startBeforeAllReady)))) + ( skip + .||. (allStable .&&. (not <$> (transceiversFailedAfterUp .||. startBeforeAllReady))) + ) + makeTopEntity 'hwCcTopologyTest tests :: HitlTestsWithPostProcData TestConfig SimConf -tests = Map.fromList - [ -- CALIBRATION -- - ----------------- - - -- detect the natual clock offsets to be elided from the later tests - calibrateClockOffsets - - -- TESTS -- - ----------- - - -- initial clock shifts startup delays topology - , tt icsDiamond ((m *) <$> sdDiamond) diamond - , tt icsComplete ((m *) <$> sdComplete) $ complete d3 - , tt icsCyclic ((m *) <$> sdCyclic) $ cyclic d5 - , tt icsTorus ((m *) <$> sdTorus) $ torus2d d2 d3 - , tt icsStar ((m *) <$> sdStar) $ star d7 - , tt icsLine ((m *) <$> sdLine) $ line d4 - , tt icsHourglass ((m *) <$> sdHourglass) $ hourglass d3 - - -- CALIBRATION VERIFICATON -- - ----------------------------- - , validateClockOffsetCalibration - ] +tests = + Map.fromList + [ -- CALIBRATION -- + ----------------- + + -- detect the natual clock offsets to be elided from the later tests + calibrateClockOffsets + , -- TESTS -- + ----------- + + -- initial clock shifts startup delays topology + tt icsDiamond ((m *) <$> sdDiamond) diamond + , tt icsComplete ((m *) <$> sdComplete) $ complete d3 + , tt icsCyclic ((m *) <$> sdCyclic) $ cyclic d5 + , tt icsTorus ((m *) <$> sdTorus) $ torus2d d2 d3 + , tt icsStar ((m *) <$> sdStar) $ star d7 + , tt icsLine ((m *) <$> sdLine) $ line d4 + , tt icsHourglass ((m *) <$> sdHourglass) $ hourglass d3 + , -- CALIBRATION VERIFICATON -- + ----------------------------- + validateClockOffsetCalibration + ] where m = 1_000_000 icsDiamond = -1000 :> -500 :> 2000 :> 3000 :> Nil - sdDiamond = 0 :> 10 :> 200 :> 3 :> Nil + sdDiamond = 0 :> 10 :> 200 :> 3 :> Nil icsComplete = -10000 :> 0 :> 10000 :> Nil - sdComplete = 200 :> 0 :> 200 :> Nil + sdComplete = 200 :> 0 :> 200 :> Nil icsCyclic = 0 :> 500 :> 1000 :> 1500 :> 2000 :> Nil - sdCyclic = 0 :> 10 :> 0 :> 100 :> 0 :> Nil + sdCyclic = 0 :> 10 :> 0 :> 100 :> 0 :> Nil icsTorus = -3000 :> -3500 :> -4000 :> 4000 :> 3500 :> 3000 :> Nil - sdTorus = 0 :> 0 :> 0 :> 100 :> 100 :> 100 :> Nil + sdTorus = 0 :> 0 :> 0 :> 100 :> 100 :> 100 :> Nil icsStar = 0 :> 1000 :> -1000 :> 2000 :> -2000 :> 3000 :> -3000 :> 4000 :> Nil - sdStar = 0 :> 40 :> 80 :> 120 :> 160 :> 200 :> 240 :> 280 :> Nil + sdStar = 0 :> 40 :> 80 :> 120 :> 160 :> 200 :> 240 :> 280 :> Nil icsLine = 10000 :> 0 :> 0 :> -10000 :> Nil - sdLine = 200 :> 0 :> 0 :> 200 :> Nil + sdLine = 200 :> 0 :> 0 :> 200 :> Nil icsHourglass = -10000 :> 10000 :> -10000 :> 10000 :> -10000 :> 10000 :> Nil - sdHourglass = 0 :> 200 :> 0 :> 200 :> 0 :> 200 :> Nil + sdHourglass = 0 :> 200 :> 0 :> 200 :> 0 :> 200 :> Nil ClockControlConfig{..} = clockControlConfig - defSimCfg = def - { samples = 1000 - , duration = natToNum @(PeriodToCycles Basic125 (Seconds 60)) - , stabilityMargin = snatToNum cccStabilityCheckerMargin - , stabilityFrameSize = snatToNum cccStabilityCheckerFramesize - , reframe = cccEnableReframing - , rusty = cccEnableRustySimulation - , waitTime = fromEnum cccReframingWaitTime - , stopAfterStable = Just - $ natToNum @(PeriodToCycles Basic125 AllStablePeriod) - } + defSimCfg = + def + { samples = 1000 + , duration = natToNum @(PeriodToCycles Basic125 (Seconds 60)) + , stabilityMargin = snatToNum cccStabilityCheckerMargin + , stabilityFrameSize = snatToNum cccStabilityCheckerFramesize + , reframe = cccEnableReframing + , rusty = cccEnableRustySimulation + , waitTime = fromEnum cccReframingWaitTime + , stopAfterStable = + Just + $ natToNum @(PeriodToCycles Basic125 AllStablePeriod) + } calibrateClockOffsets = calibrateCC False validateClockOffsetCalibration = calibrateCC True calibrateCC validate = ( -- the names must be chosen such that the run is executed first/last (if validate then "zzz_validate" else "0_calibrate") <> "_clock_offsets" - , ( toList $ imap (,) $ repeat @FpgaCount TestConfig - { fpgaEnabled = True - , calibrate = if validate - then CCCalibrationValidation - else CCCalibrate - , stepSizeSelect = commonStepSizeSelect - , initialClockShift = 0 - , startupDelay = 0 - , mask = maxBound - } + , + ( toList + $ imap (,) + $ repeat @FpgaCount + TestConfig + { fpgaEnabled = True + , calibrate = + if validate + then CCCalibrationValidation + else CCCalibrate + , stepSizeSelect = commonStepSizeSelect + , initialClockShift = 0 + , startupDelay = 0 + , mask = maxBound + } , defSimCfg { mTopologyType = Just $ Complete $ natToInteger @FpgaCount - , clockOffsets = toList $ repeat @FpgaCount 0 + , clockOffsets = toList $ repeat @FpgaCount 0 , startupDelays = toList $ repeat @FpgaCount 0 } ) ) - - -- tests the given topology tt :: forall n. @@ -735,16 +882,18 @@ tests = Map.fromList (TestName, (Probes TestConfig, SimConf)) tt clockShifts startDelays t = ( fromString $ topologyName t - , ( toList ( zipWith4 testData indicesI clockShifts startDelays - $ linkMasks @n t - ) + , + ( toList + ( zipWith4 testData indicesI clockShifts startDelays + $ linkMasks @n t + ) <> [ (fromInteger i, disabled) | let n = natToNum @n , i <- [n, n + 1 .. natToNum @LinkCount] ] , let -- clock period in picoseconds - clkPeriodPs :: Num a => a + clkPeriodPs :: (Num a) => a clkPeriodPs = case clockControlConfig of (_ :: ClockControlConfig dom a b c) -> snatToNum (clockPeriod @dom) @@ -754,17 +903,20 @@ tests = Map.fromList -- Femtoseconds for 'clkPeriodPs' already applied at this -- point to reduce the loss-op-presion introduced otherwise. stepSizeDiv = case commonStepSizeSelect of - PPB_1 -> 1_000_000 - PPB_10 -> 100_000 - PPB_100 -> 10_000 - PPM_1 -> 1_000 - in - defSimCfg { mTopologyType = Just $ topologyType t - , clockOffsets = - (/ stepSizeDiv) . (* clkPeriodPs) . fromIntegral - <$> toList clockShifts - , startupDelays = fromIntegral <$> toList startDelays - } + PPB_1 -> 1_000_000 + PPB_10 -> 100_000 + PPB_100 -> 10_000 + PPM_1 -> 1_000 + in + defSimCfg + { mTopologyType = Just $ topologyType t + , clockOffsets = + (/ stepSizeDiv) + . (* clkPeriodPs) + . fromIntegral + <$> toList clockShifts + , startupDelays = fromIntegral <$> toList startDelays + } ) ) @@ -779,8 +931,8 @@ tests = Map.fromList testData i initialClockShift startupDelay mask = ( zeroExtend @Index @n @(FpgaCount - n) i , TestConfig - { fpgaEnabled = True - , calibrate = NoCCCalibration + { fpgaEnabled = True + , calibrate = NoCCCalibration , stepSizeSelect = commonStepSizeSelect , .. } diff --git a/bittide-instances/src/Bittide/Instances/Hitl/IlaPlot.hs b/bittide-instances/src/Bittide/Instances/Hitl/IlaPlot.hs index fbfdf8355..6e7146aac 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/IlaPlot.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/IlaPlot.hs @@ -1,49 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | ILA extension for the generation of plot data monitoring the --- clock modifications and the data counts of the elastic buffers. The --- extension is intended to be used by the hardware-in-the-loop tests. -module Bittide.Instances.Hitl.IlaPlot - ( -- * Parameters - SyncPulsePeriod - , ScheduledCapturePeriod - , AccWindowHeight - , CompressedBufferSize - , MaxPulseCount - -- * Timestamp Types - , GlobalTimestamp - , LocalTimestamp - -- * Interface Types - , CaptureCondition(..) - , IlaPlotSetup(..) - , IlaControl(..) - , PlotData(..) - , RfStageChange(..) - -- * ILA Plot - , ilaProbeNames - , ilaPlotSetup - , callistoClockControlWithIla - -- * Helpers - , SyncPulseCycles - , ScheduledCaptureCycles - , DDiv - , DDivCheck - , accWindow - , overflowResistantDiff - , DiffResult(..) - , syncOutGenerator - , syncInRecover - ) where +{- | ILA extension for the generation of plot data monitoring the +clock modifications and the data counts of the elastic buffers. The +extension is intended to be used by the hardware-in-the-loop tests. +-} +module Bittide.Instances.Hitl.IlaPlot ( + -- * Parameters + SyncPulsePeriod, + ScheduledCapturePeriod, + AccWindowHeight, + CompressedBufferSize, + MaxPulseCount, + + -- * Timestamp Types + GlobalTimestamp, + LocalTimestamp, + + -- * Interface Types + CaptureCondition (..), + IlaPlotSetup (..), + IlaControl (..), + PlotData (..), + RfStageChange (..), + + -- * ILA Plot + ilaProbeNames, + ilaPlotSetup, + callistoClockControlWithIla, + + -- * Helpers + SyncPulseCycles, + ScheduledCaptureCycles, + DDiv, + DDivCheck, + accWindow, + overflowResistantDiff, + DiffResult (..), + syncOutGenerator, + syncInRecover, +) where import GHC.Stack (HasCallStack) @@ -52,103 +55,126 @@ import Clash.Explicit.Signal.Extra import Clash.Sized.Extra (concatUnsigneds) import Bittide.Arithmetic.Time (PeriodToCycles, trueFor) -import Bittide.ClockControl (SpeedChange(..), RelDataCount, ClockControlConfig) -import Bittide.ClockControl.Callisto - (CallistoResult(..), ReframingState(..), callistoClockControl) +import Bittide.ClockControl (ClockControlConfig, RelDataCount, SpeedChange (..)) +import Bittide.ClockControl.Callisto ( + CallistoResult (..), + ReframingState (..), + callistoClockControl, + ) import Bittide.ClockControl.StabilityChecker import Bittide.Extra.Maybe (orNothing) +import Clash.Cores.Xilinx.Ila (Depth (..), IlaConfig (..), ila, ilaConfig) import Clash.Cores.Xilinx.Xpm.Cdc.Gray (xpmCdcGray) import Clash.Cores.Xilinx.Xpm.Cdc.Single (xpmCdcSingle) -import Clash.Cores.Xilinx.Ila (IlaConfig(..), Depth(..), ila, ilaConfig) import Clash.Explicit.Reset.Extra -import Control.Arrow ((***), second) +import Control.Arrow (second, (***)) import Data.Bool (bool) -import Data.Maybe (isJust, fromMaybe) -import Data.Constraint.Nat.Extra - (Dict(..), SatSubZero, satSubZeroMin, minLeq, maxGeqPlus) - --- | Divisible division operation, which ensures that the dividend is --- always a multiple of the divisor. Type family resolution will get --- /stuck/ if the dividend is not a multiple of the divisor. +import Data.Constraint.Nat.Extra ( + Dict (..), + SatSubZero, + maxGeqPlus, + minLeq, + satSubZeroMin, + ) +import Data.Maybe (fromMaybe, isJust) + +{- | Divisible division operation, which ensures that the dividend is +always a multiple of the divisor. Type family resolution will get +/stuck/ if the dividend is not a multiple of the divisor. +-} type family DDiv (a :: Nat) (b :: Nat) :: Nat where DDiv a b = DDivCheck (Mod a b) a b --- | Helper type family for checking the reminder of --- 'DDiv'. Unfortunately type families cannot be scoped. +{- | Helper type family for checking the reminder of +'DDiv'. Unfortunately type families cannot be scoped. +-} type family DDivCheck (a :: Nat) (b :: Nat) (c :: Nat) :: Nat where DDivCheck 0 a b = Div a b --- | The window high of 'accWindow' for reducing the number of --- reported clock modifications. +{- | The window high of 'accWindow' for reducing the number of +reported clock modifications. +-} type AccWindowHeight = 5 :: Nat --- | The period of the sync pulse used to share a synchronized time --- stamp between the nodes. +{- | The period of the sync pulse used to share a synchronized time +stamp between the nodes. +-} type SyncPulsePeriod = Milliseconds 5 -- | The period of the scheduled capture (must be a multiple of 'SyncPulsePeriod'). type ScheduledCapturePeriod = Milliseconds 20 --- | An upper bound on the number of synchronized pulses during a test --- run. The bound allows to count pulses up to 5 minutes without --- producing an overflow. We assume that the test has finished or was --- canceled within that time. +{- | An upper bound on the number of synchronized pulses during a test +run. The bound allows to count pulses up to 5 minutes without +producing an overflow. We assume that the test has finished or was +canceled within that time. +-} type MaxPulseCount = DDiv (5 * 60 * Seconds 1) SyncPulsePeriod --- | The number of cycles within the given domain that fit into one --- sync pulse period. +{- | The number of cycles within the given domain that fit into one +sync pulse period. +-} type SyncPulseCycles dom = PeriodToCycles dom SyncPulsePeriod --- | A global timestamp consisting of the number of synchronized --- pulses received and the number of cycles of the local stable clock --- (identified by the given domain and starting with 'syncStart'). The --- local clock cycle counter can count up to 10% more cycles than --- mathematically required to compensate potential drifts of the local --- stable clock. +{- | A global timestamp consisting of the number of synchronized +pulses received and the number of cycles of the local stable clock +(identified by the given domain and starting with 'syncStart'). The +local clock cycle counter can count up to 10% more cycles than +mathematically required to compensate potential drifts of the local +stable clock. +-} type GlobalTimestamp dom = ( Index MaxPulseCount , Index (Div (SyncPulseCycles dom) 10 + SyncPulseCycles dom) ) --- | The number of cycles within the given domain fitting into one --- scheduled capture period. +{- | The number of cycles within the given domain fitting into one +scheduled capture period. +-} type ScheduledCaptureCycles dom = PeriodToCycles dom ScheduledCapturePeriod --- | The local timestamp counting the cycles of the dynamic clock --- since the last scheduled capture (starting with clock control). --- The counter can count up to 10% more cycles than mathematically --- required to compensate for clock changes resulting from --- 'Bittide.ClockControl.SpeedUp' and 'Bittide.ClockControl.SlowDown' --- applications. -type LocalTimestamp dom = Index (ScheduledCaptureCycles dom + Div - (ScheduledCaptureCycles dom) 10) - --- | The number of pulses it takes until a scheduled capture gets --- triggered. +{- | The local timestamp counting the cycles of the dynamic clock +since the last scheduled capture (starting with clock control). +The counter can count up to 10% more cycles than mathematically +required to compensate for clock changes resulting from +'Bittide.ClockControl.SpeedUp' and 'Bittide.ClockControl.SlowDown' +applications. +-} +type LocalTimestamp dom = + Index + ( ScheduledCaptureCycles dom + + Div + (ScheduledCaptureCycles dom) + 10 + ) + +{- | The number of pulses it takes until a scheduled capture gets +triggered. +-} type ScheduledPulseCount = DDiv ScheduledCapturePeriod SyncPulsePeriod --- | The reduced elastic buffer size to be used for reporting only the --- difference since the last capture. +{- | The reduced elastic buffer size to be used for reporting only the +difference since the last capture. +-} type CompressedBufferSize = 16 :: Nat -- | The type of change with respect to the stage of 'ReframingState'. -data RfStageChange = +data RfStageChange + = -- | Indicates that the reframing stage is stable and does not change. Stable - -- ^ Indicates that the reframing stage is stable and does not change. - | ToDetect - -- ^ Indicates that the reframing stage changed to the @DETECT@ state. - | ToWait - -- ^ Indicates that the reframing stage changed to the @WAIT@ state. - | ToDone - -- ^ Indicates that the reframing stage changed to the @DONE@ state. + | -- | Indicates that the reframing stage changed to the @DETECT@ state. + ToDetect + | -- | Indicates that the reframing stage changed to the @WAIT@ state. + ToWait + | -- | Indicates that the reframing stage changed to the @DONE@ state. + ToDone deriving (Eq, Generic, BitPack, NFDataX) -- | The ILA capture type. -data CaptureCondition = - UntilTrigger - -- ^ Identifies captures happening with or before the trigger. +data CaptureCondition + = -- | Identifies captures happening with or before the trigger. -- -- Note that we always need to capture everything before the -- trigger fires, because the data that the ILA captures is @@ -156,97 +182,99 @@ data CaptureCondition = -- trigger, but only after it. Hence, if the trigger position is -- at 0, then we store exactly one capture that is marked with the -- 'UntilTrigger' flag this way. - | Calibrate - -- ^ Identifies scheduled captures during the initial calibration + UntilTrigger + | -- | Identifies scheduled captures during the initial calibration -- period. - | Scheduled - -- ^ Identifies scheduled captures after the initial calibration + Calibrate + | -- | Identifies scheduled captures after the initial calibration -- period. - | DataChange - -- ^ Identifies intermediate captures that are triggered by data + Scheduled + | -- | Identifies intermediate captures that are triggered by data -- changes. + DataChange deriving (Eq, Generic, NFDataX, BitPack) --- | All signals, as they are required for using clock control with --- ILA plotting capabilities. -data IlaPlotSetup dom = - IlaPlotSetup - { sysClk :: Clock dom - -- ^ The stable system clock. - , sysRst :: Reset dom - -- ^ The system's reset line. - , allReady :: Signal dom Bool - -- ^ A boolean signal indicating that all transceivers are ready. See - -- 'Bittide.Transceiver.Output.linkReady'. - , startTest :: Signal dom Bool - -- ^ The test start signal coming from the HITLT VIO interface. - , syncIn :: Signal dom Bool - -- ^ The signal connected to @SYNC_IN@. - } - --- | All signals, as they are required by the ILA trigger and capture --- conditions. You must use 'ilaPlotSetup' for generating them. -data IlaControl dom = - IlaControl - { syncRst :: Reset dom - -- ^ Synchronized reset line, which is only deasserted during - -- the actual test. - , syncOut :: Signal dom Bool - -- ^ The signal to be passed to @SYNC_OUT@, which - -- is only connected for the last node in the network and wired back - -- to @SYNC_IN@ of all nodes from there. - -- - -- Note that all nodes are in reset before their local - -- 'startTest' VIO signal gets asserted, as 'startTest' is - -- directly driving 'sysRst'. Thus, for the other nodes to - -- capture the @SYNC_OUT@ signal correctly, the node receiving - -- the `startTest` rising edge last must be the one with it's - -- @SYNC_OUT@ physically connected to the @SYNC_IN@ of all nodes - -- in the network. This assumption is tested by - -- 'Bittide.Instances.Hitl.SyncInSyncOut'. - , syncStart :: Signal dom Bool - -- ^ Synchronized test start trigger - , scheduledCapture :: Signal dom Bool - -- ^ Synchronized pre-scheduled capture trigger - , globalTimestamp :: Signal dom (GlobalTimestamp dom) - -- ^ Synchronized pulse counter - , skipTest :: Signal dom Bool - -- ^ Skip this test - } +{- | All signals, as they are required for using clock control with +ILA plotting capabilities. +-} +data IlaPlotSetup dom = IlaPlotSetup + { sysClk :: Clock dom + -- ^ The stable system clock. + , sysRst :: Reset dom + -- ^ The system's reset line. + , allReady :: Signal dom Bool + -- ^ A boolean signal indicating that all transceivers are ready. See + -- 'Bittide.Transceiver.Output.linkReady'. + , startTest :: Signal dom Bool + -- ^ The test start signal coming from the HITLT VIO interface. + , syncIn :: Signal dom Bool + -- ^ The signal connected to @SYNC_IN@. + } + +{- | All signals, as they are required by the ILA trigger and capture +conditions. You must use 'ilaPlotSetup' for generating them. +-} +data IlaControl dom = IlaControl + { syncRst :: Reset dom + -- ^ Synchronized reset line, which is only deasserted during + -- the actual test. + , syncOut :: Signal dom Bool + -- ^ The signal to be passed to @SYNC_OUT@, which + -- is only connected for the last node in the network and wired back + -- to @SYNC_IN@ of all nodes from there. + -- + -- Note that all nodes are in reset before their local + -- 'startTest' VIO signal gets asserted, as 'startTest' is + -- directly driving 'sysRst'. Thus, for the other nodes to + -- capture the @SYNC_OUT@ signal correctly, the node receiving + -- the `startTest` rising edge last must be the one with it's + -- @SYNC_OUT@ physically connected to the @SYNC_IN@ of all nodes + -- in the network. This assumption is tested by + -- 'Bittide.Instances.Hitl.SyncInSyncOut'. + , syncStart :: Signal dom Bool + -- ^ Synchronized test start trigger + , scheduledCapture :: Signal dom Bool + -- ^ Synchronized pre-scheduled capture trigger + , globalTimestamp :: Signal dom (GlobalTimestamp dom) + -- ^ Synchronized pulse counter + , skipTest :: Signal dom Bool + -- ^ Skip this test + } -- | Names of the additional ILA plot probes. ilaProbeNames :: Vec 6 String ilaProbeNames = - "trigger_1" - :> "capture_1" - :> "condition" - :> "global" - :> "local" - :> "data" - :> Nil + "trigger_1" + :> "capture_1" + :> "condition" + :> "global" + :> "local" + :> "data" + :> Nil -- | The ILA plot setup controller. ilaPlotSetup :: - forall dom. HasCallStack => + forall dom. + (HasCallStack) => (HasDefinedInitialValues dom, HasSynchronousReset dom) => + -- | required input signals IlaPlotSetup dom -> - -- ^ required input signals IlaControl dom ilaPlotSetup IlaPlotSetup{..} = IlaControl{..} where -- 'syncOutGenerator' is used to drive 'SYNC_OUT'. syncOut = - dflipflop sysClk - $ syncOutGenerator sysClk startTest - $ trueFor (SNat @(Seconds 5)) sysClk syncRst allReady + dflipflop sysClk + $ syncOutGenerator sysClk startTest + $ trueFor (SNat @(Seconds 5)) sysClk syncRst allReady -- first synchronize SYNC_IN to the local clock and filter from -- potential glitches syncInFiltered = - unsafeToActiveLow - $ resetGlitchFilter (SNat @128) sysClk - $ unsafeFromActiveLow - $ xpmCdcSingle sysClk sysClk syncIn + unsafeToActiveLow + $ resetGlitchFilter (SNat @128) sysClk + $ unsafeFromActiveLow + $ xpmCdcSingle sysClk sysClk syncIn -- generate a pulse on every change of SYNC_IN syncInChangepoints = @@ -261,44 +289,52 @@ ilaPlotSetup IlaPlotSetup{..} = IlaControl{..} -- generate the global timestamp from the synchronous rising and -- falling edges of SYNC_IN - globalTimestamp = register sysClk syncRst enableGen (0,0) $ - mux syncInChangepoints - (((+1) *** const 0) <$> globalTimestamp) - (second (+1) <$> globalTimestamp) - - scheduledCapture = syncStart .&&. - mealy sysClk syncRst enableGen - (\c i -> (if i then satSucc SatWrap c else c, i && c == minBound)) - (minBound :: Index ScheduledPulseCount) - syncInChangepoints + globalTimestamp = + register sysClk syncRst enableGen (0, 0) + $ mux + syncInChangepoints + (((+ 1) *** const 0) <$> globalTimestamp) + (second (+ 1) <$> globalTimestamp) + + scheduledCapture = + syncStart + .&&. mealy + sysClk + syncRst + enableGen + (\c i -> (if i then satSucc SatWrap c else c, i && c == minBound)) + (minBound :: Index ScheduledPulseCount) + syncInChangepoints skipTest = pure False --- | A single data type for covering all of the non-clock related data --- to be included into a capture. -data PlotData (n :: Nat) (m :: Nat) = - PlotData - { dEBData :: Vec n (RelDataCount m, Maybe Bool, Maybe Bool) - , dSpeedChange :: SpeedChange - , dRfStageChange :: RfStageChange - } +{- | A single data type for covering all of the non-clock related data +to be included into a capture. +-} +data PlotData (n :: Nat) (m :: Nat) = PlotData + { dEBData :: Vec n (RelDataCount m, Maybe Bool, Maybe Bool) + , dSpeedChange :: SpeedChange + , dRfStageChange :: RfStageChange + } deriving (Generic, NFDataX, BitPack) --- | Accumulates over multiple @FINC@/@FDEC@s to reduce the number of --- captures recorded by the ILA (which are mostly jitter otherwise). --- --- The compression technique works as follows: if both @FINC@ and --- @FDEC@ are requested after each other, then they cancel each other --- out and are not reported. Hence, only @FINC@/@FDEC@s are reported --- that haven't canceled out before they exceed the @n@ --- boundary. Thus, for example @FINC@, @FINC@, @FDEC@, @FDEC@, ... is --- not reported for @n > 2@ as the first two @FINC@s don't exceed the --- boundary @n@. +{- | Accumulates over multiple @FINC@/@FDEC@s to reduce the number of +captures recorded by the ILA (which are mostly jitter otherwise). + +The compression technique works as follows: if both @FINC@ and +@FDEC@ are requested after each other, then they cancel each other +out and are not reported. Hence, only @FINC@/@FDEC@s are reported +that haven't canceled out before they exceed the @n@ +boundary. Thus, for example @FINC@, @FINC@, @FDEC@, @FDEC@, ... is +not reported for @n > 2@ as the first two @FINC@s don't exceed the +boundary @n@. +-} accWindow :: - forall height dom. HasCallStack => + forall height dom. + (HasCallStack) => (KnownNat height, KnownDomain dom) => + -- | The height of the accumulation window. SNat height -> - -- ^ The height of the accumulation window. Clock dom -> Reset dom -> Enable dom -> @@ -307,34 +343,38 @@ accWindow :: accWindow _ clk rst ena = mealy clk rst ena transF (True, minBound :: Index height) where - transF (d,s) = \case + transF (d, s) = \case NoChange -> ((d, s), NoChange) - x -> let d' = if x == SpeedUp then d else not d in if - | d' && s == maxBound -> ((not d, minBound), x ) - | not d' && s == minBound -> ((not d, minBound), NoChange) - | d' -> ((d, s + 1), NoChange) - | otherwise -> ((d, s - 1), NoChange) - --- | Calculates the difference of a wrapping counter between two --- points in time taking potential overflows into account. The --- captured difference is wrapped into an option type, which defaults --- to 'TooLarge' as soon as the difference exceeds the capacity of the --- returned index type. --- --- The difference is measured against a stored reference, which is --- taken from the counter whenever the additional input signal gets --- asserted. 'NoReference' is output before the first assertion of this --- line. --- --- The counter is assumed to only increase over time and may overflow --- several times until the next value gets stored. This means that the --- returned difference is measured against the point in time where the --- reference was stored (accumulating every overflow since then) and --- not against the actual value of the counter at that time. The --- counter can increase by any value in the range of the counter's --- type per cycle. + x -> + let d' = if x == SpeedUp then d else not d + in if + | d' && s == maxBound -> ((not d, minBound), x) + | not d' && s == minBound -> ((not d, minBound), NoChange) + | d' -> ((d, s + 1), NoChange) + | otherwise -> ((d, s - 1), NoChange) + +{- | Calculates the difference of a wrapping counter between two +points in time taking potential overflows into account. The +captured difference is wrapped into an option type, which defaults +to 'TooLarge' as soon as the difference exceeds the capacity of the +returned index type. + +The difference is measured against a stored reference, which is +taken from the counter whenever the additional input signal gets +asserted. 'NoReference' is output before the first assertion of this +line. + +The counter is assumed to only increase over time and may overflow +several times until the next value gets stored. This means that the +returned difference is measured against the point in time where the +reference was stored (accumulating every overflow since then) and +not against the actual value of the counter at that time. The +counter can increase by any value in the range of the counter's +type per cycle. +-} overflowResistantDiff :: - forall dom n m. HasCallStack => + forall dom n m. + (HasCallStack) => (KnownDomain dom, KnownNat n, KnownNat m) => (1 <= n, 1 <= m) => Clock dom -> @@ -350,32 +390,39 @@ overflowResistantDiff clk rst trg cnt = where transF state (curValue, newRef) = if newRef - then (Difference (curValue, 0, 0), Difference 0) - else case state of - TooLarge -> (TooLarge, TooLarge) - NoReference -> (NoReference, NoReference) - Difference (refValue, prevOverflows, prevDiff) -> - let curDiff = curValue - refValue - curOverflows = - if curDiff < prevDiff - then satSucc SatError prevOverflows - else prevOverflows - in if prevOverflows == maxOverflows && curDiff < prevDiff - || curOverflows == maxOverflows && curDiff > maxDiff - then (TooLarge, TooLarge) - else (Difference (refValue, curOverflows, curDiff), ) - $ case satSubZeroMin @(BitSize (Index m)) @n of - Dict -> case minLeq @(BitSize (Index m)) @n of - Dict -> Difference - $ bitCoerce - $ concatUnsigneds curOverflows - $ checkedTruncateB - @(Min (BitSize (Index m)) n) - @(n - Min (BitSize (Index m)) n) - curDiff + then (Difference (curValue, 0, 0), Difference 0) + else case state of + TooLarge -> (TooLarge, TooLarge) + NoReference -> (NoReference, NoReference) + Difference (refValue, prevOverflows, prevDiff) -> + let curDiff = curValue - refValue + curOverflows = + if curDiff < prevDiff + then satSucc SatError prevOverflows + else prevOverflows + in if prevOverflows + == maxOverflows + && curDiff + < prevDiff + || curOverflows + == maxOverflows + && curDiff + > maxDiff + then (TooLarge, TooLarge) + else (Difference (refValue, curOverflows, curDiff),) + $ case satSubZeroMin @(BitSize (Index m)) @n of + Dict -> case minLeq @(BitSize (Index m)) @n of + Dict -> + Difference + $ bitCoerce + $ concatUnsigneds curOverflows + $ checkedTruncateB + @(Min (BitSize (Index m)) n) + @(n - Min (BitSize (Index m)) n) + curDiff maxDiff :: Unsigned n - maxDiff = natToNum @(Mod (m-1) (2^n)) + maxDiff = natToNum @(Mod (m - 1) (2 ^ n)) maxOverflows :: Unsigned (SatSubZero (BitSize (Index m)) n) maxOverflows = @@ -385,88 +432,98 @@ overflowResistantDiff clk rst trg cnt = Dict -> checkedTruncateB x -- | The result of 'overflowResistantDiff'. -data DiffResult a = - NoReference - -- ^ Wait for the first pulse to store the initial reference +data DiffResult a + = -- | Wait for the first pulse to store the initial reference -- value. - | Difference a - -- ^ The accumulated difference since the last value has been + NoReference + | -- | The accumulated difference since the last value has been -- stored. - | TooLarge - -- ^ Indicates that the difference against the last stored + Difference a + | -- | Indicates that the difference against the last stored -- reference got to large to fit into the output type. + TooLarge deriving (Generic, BitPack, NFDataX, Functor, Eq, Ord, Show) {-# NOINLINE callistoClockControlWithIla #-} --- | Wrapper on 'Bittide.ClockControl.Callisto.callistoClockControl' --- additionally dumping all the data that is required for producing --- plots of the clock control behavior. + +{- | Wrapper on 'Bittide.ClockControl.Callisto.callistoClockControl' +additionally dumping all the data that is required for producing +plots of the clock control behavior. +-} callistoClockControlWithIla :: - forall n m sys dyn margin framesize. HasCallStack => - (KnownDomain dyn , KnownDomain sys, HasSynchronousReset sys) => + forall n m sys dyn margin framesize. + (HasCallStack) => + (KnownDomain dyn, KnownDomain sys, HasSynchronousReset sys) => (KnownNat n, KnownNat m, KnownNat margin, KnownNat framesize) => (1 <= n, 1 <= m, n + m <= 32, 1 <= framesize, 6 + n * (m + 4) <= 1024) => - CompressedBufferSize <= m => + (CompressedBufferSize <= m) => Clock dyn -> Clock sys -> Reset sys -> ClockControlConfig sys m margin framesize -> + -- | Ila trigger and capture conditions IlaControl sys -> - -- ^ Ila trigger and capture conditions + -- | Link availability mask Signal sys (BitVector n) -> - -- ^ Link availability mask + -- | Statistics provided by elastic buffers. Vec n (Signal sys (RelDataCount m)) -> - -- ^ Statistics provided by elastic buffers. Signal sys (CallistoResult n) callistoClockControlWithIla dynClk clk rst ccc IlaControl{..} mask ebs = hwSeqX ilaInstance (muteDuringCalibration <$> calibrating <*> result) where result = callistoClockControl clk rst enableGen ccc mask ebs - filterCounts vMask vCounts = flip map (zip vMask vCounts) $ - \(isActive, count) -> if isActive == high then count else 0 + filterCounts vMask vCounts = flip map (zip vMask vCounts) + $ \(isActive, count) -> if isActive == high then count else 0 - filterIndicators vMask vCounts = flip map (zip vMask vCounts) $ - \(isActive, ind) -> if isActive == high then ind else StabilityIndication False False + filterIndicators vMask vCounts = flip map (zip vMask vCounts) + $ \(isActive, ind) -> if isActive == high then ind else StabilityIndication False False - maxGeqPlusApp = maxGeqPlus @1 - @(DivRU ScheduledCapturePeriod (Max 1 (DomainPeriod dyn))) - @(Div (ScheduledCaptureCycles dyn) 10) + maxGeqPlusApp = + maxGeqPlus @1 + @(DivRU ScheduledCapturePeriod (Max 1 (DomainPeriod dyn))) + @(Div (ScheduledCaptureCycles dyn) 10) -- local timestamp on the stable clock localTs :: Signal sys (DiffResult (LocalTimestamp dyn)) localTs = case maxGeqPlusApp of - Dict -> overflowResistantDiff clk syncRst - (delay clk enableGen False (isJust <$> captureCond)) - $ let ccRst = xpmResetSynchronizer Asserted clk dynClk syncRst - lts :: Signal dyn (Unsigned 8) - lts = register dynClk ccRst enableGen minBound - $ satSucc SatWrap <$> lts - in xpmCdcGray dynClk clk lts + Dict -> + overflowResistantDiff + clk + syncRst + (delay clk enableGen False (isJust <$> captureCond)) + $ let ccRst = xpmResetSynchronizer Asserted clk dynClk syncRst + lts :: Signal dyn (Unsigned 8) + lts = + register dynClk ccRst enableGen minBound + $ satSucc SatWrap + <$> lts + in xpmCdcGray dynClk clk lts -- collect all plot data localData = let rfStageChange CallistoResult{..} = case reframingState of - Detect {} -> ToDetect - Wait {} -> ToWait - Done {} -> ToDone + Detect{} -> ToDetect + Wait{} -> ToWait + Done{} -> ToDone height = SNat @AccWindowHeight - idcs = unbundle - (filterIndicators <$> fmap bv2v mask <*> (stability <$> result)) + idcs = + unbundle + (filterIndicators <$> fmap bv2v mask <*> (stability <$> result)) -- get the points in time where the monitored values change - stableUpdates = changepoints clk rst enableGen <$> (fmap stable <$> idcs) + stableUpdates = changepoints clk rst enableGen <$> (fmap stable <$> idcs) settledUpdates = changepoints clk rst enableGen <$> (fmap settled <$> idcs) - modeUpdate = changepoints clk rst enableGen (rfStageChange <$> result) + modeUpdate = changepoints clk rst enableGen (rfStageChange <$> result) - combine eb stU seU ind = (,,) - <$> eb - <*> (orNothing <$> stU <*> (stable <$> ind)) - <*> (orNothing <$> seU <*> (settled <$> ind)) + combine eb stU seU ind = + (,,) + <$> eb + <*> (orNothing <$> stU <*> (stable <$> ind)) + <*> (orNothing <$> seU <*> (settled <$> ind)) noChange = fromMaybe NoChange . maybeSpeedChange - in PlotData <$> bundle (zipWith4 combine ebsC stableUpdates settledUpdates idcs) <*> accWindow height clk rst enableGen (noChange <$> result) @@ -474,37 +531,50 @@ callistoClockControlWithIla dynClk clk rst ccc IlaControl{..} mask ebs = -- compress the elastic buffer data via only reporting the -- differences since the last capture - (ebDataChange, ebsC) = second unbundle $ - let transF storedDataCounts (trigger, curDataCounts) = - let diffs = zipWith (-) curDataCounts storedDataCounts - half = extend @_ - @(CompressedBufferSize - 1) - @(m - CompressedBufferSize + 1) - maxBound - truncDiffs = truncateB @_ - @CompressedBufferSize - @(m - CompressedBufferSize) - <$> diffs - in if trigger || any ((> half) . abs) diffs - then (curDataCounts, (True, truncDiffs)) - else (storedDataCounts, (False, repeat 0)) - in mealyB clk rst enableGen transF (repeat 0) - ( scheduledCapture - , filterCounts <$> fmap bv2v mask <*> bundle ebs - ) + (ebDataChange, ebsC) = + second unbundle + $ let transF storedDataCounts (trigger, curDataCounts) = + let diffs = zipWith (-) curDataCounts storedDataCounts + half = + extend @_ + @(CompressedBufferSize - 1) + @(m - CompressedBufferSize + 1) + maxBound + truncDiffs = + truncateB @_ + @CompressedBufferSize + @(m - CompressedBufferSize) + <$> diffs + in if trigger || any ((> half) . abs) diffs + then (curDataCounts, (True, truncDiffs)) + else (storedDataCounts, (False, repeat 0)) + in mealyB + clk + rst + enableGen + transF + (repeat 0) + ( scheduledCapture + , filterCounts <$> fmap bv2v mask <*> bundle ebs + ) -- produce at least two calibration captures - calibrating = unsafeToActiveLow syncRst .&&. - moore clk syncRst enableGen - (\s -> bool s $ satSucc SatBound s) - (/= maxBound) - (minBound :: Index 3) - scheduledCapture + calibrating = + unsafeToActiveLow syncRst + .&&. moore + clk + syncRst + enableGen + (\s -> bool s $ satSucc SatBound s) + (/= maxBound) + (minBound :: Index 3) + scheduledCapture -- do not forward clock modifications during calibration - muteDuringCalibration active ccResult = ccResult - { maybeSpeedChange = bool (maybeSpeedChange ccResult) Nothing active - } + muteDuringCalibration active ccResult = + ccResult + { maybeSpeedChange = bool (maybeSpeedChange ccResult) Nothing active + } -- Note that we always need to capture everything before the trigger -- fires, because the data that the ILA captures is undefined @@ -513,21 +583,25 @@ callistoClockControlWithIla dynClk clk rst ccc IlaControl{..} mask ebs = -- we store exactly one capture that is marked with the -- @UntilTrigger@ flag this way. captureCond :: Signal sys (Maybe CaptureCondition) - captureCond = mux (not <$> syncStart) - (pure $ Just UntilTrigger) - (fmap fst <$> plotData) + captureCond = + mux + (not <$> syncStart) + (pure $ Just UntilTrigger) + (fmap fst <$> plotData) plotData = let captureType calibrate scheduled dc dat - | scheduled && calibrate = Just (Calibrate, dat) - | scheduled = Just (Scheduled, dat) + | scheduled && calibrate = Just (Calibrate, dat) + | scheduled = Just (Scheduled, dat) | dc || dataChange dat && not calibrate = Just (DataChange, dat) - | otherwise = Nothing + | otherwise = Nothing dataChange PlotData{..} = - any (\(_, x, y) -> isJust x || isJust y) dEBData - || dSpeedChange /= NoChange - || dRfStageChange /= Stable + any (\(_, x, y) -> isJust x || isJust y) dEBData + || dSpeedChange + /= NoChange + || dRfStageChange + /= Stable in captureType <$> calibrating <*> scheduledCapture @@ -536,32 +610,34 @@ callistoClockControlWithIla dynClk clk rst ccc IlaControl{..} mask ebs = ilaInstance :: Signal sys () ilaInstance = - setName @"ilaPlot" $ ila - (ilaConfig ilaProbeNames) { depth = D16384, stages = 2 } - -- the ILA must run on a stable clock - clk - -- trigger as soon as we start - (syncStart .&&. (not <$> skipTest)) - -- capture on relevant data changes - (syncStart .&&. (isJust <$> captureCond) .&&. (not <$> skipTest)) - -- capture the capture condition - (fromMaybe UntilTrigger <$> captureCond) - -- capture the globally synchronized timestamp - globalTimestamp - -- capture the local timestamp - localTs - -- capture all relevant plot data - (maybe dummy snd <$> plotData) - - dummy = PlotData - { dEBData = repeat (0, Nothing, Nothing) - , dSpeedChange = NoChange - , dRfStageChange = Stable - } + setName @"ilaPlot" + $ ila + (ilaConfig ilaProbeNames){depth = D16384, stages = 2} + -- the ILA must run on a stable clock + clk + -- trigger as soon as we start + (syncStart .&&. (not <$> skipTest)) + -- capture on relevant data changes + (syncStart .&&. (isJust <$> captureCond) .&&. (not <$> skipTest)) + -- capture the capture condition + (fromMaybe UntilTrigger <$> captureCond) + -- capture the globally synchronized timestamp + globalTimestamp + -- capture the local timestamp + localTs + -- capture all relevant plot data + (maybe dummy snd <$> plotData) + + dummy = + PlotData + { dEBData = repeat (0, Nothing, Nothing) + , dSpeedChange = NoChange + , dRfStageChange = Stable + } -- | The state space of the Mealy machine for producing @SYNC_OUT@. -data SyncOutGen dom = - GettingReady +data SyncOutGen dom + = GettingReady | WaitAtLeast (Index (SyncPulseCycles dom)) | WaitForTransceivers | SyncPulse Bool (Index (SyncPulseCycles dom)) @@ -570,65 +646,75 @@ data SyncOutGen dom = -- | The signal transformer for producing @SYNC_OUT@. syncOutGenerator :: - forall dom. HasCallStack => - KnownDomain dom => + forall dom. + (HasCallStack) => + (KnownDomain dom) => Clock dom -> + -- | The generator starts after this input has turned high. Signal dom Bool -> - -- ^ The generator starts after this input has turned high. + -- | The transceivers being ready indicator. Signal dom Bool -> - -- ^ The transceivers being ready indicator. + -- | The generated @SYNC_OUT@ signal. Signal dom Bool - -- ^ The generated @SYNC_OUT@ signal. syncOutGenerator clk start inp = - start .&&. - mealyB clk (unsafeFromActiveLow start) enableGen - transF (GettingReady :: SyncOutGen dom) inp + start + .&&. mealyB + clk + (unsafeFromActiveLow start) + enableGen + transF + (GettingReady :: SyncOutGen dom) + inp where - transF GettingReady _ = (WaitAtLeast maxBound, False) - transF (WaitAtLeast 0) True = (SyncPulse False maxBound, False) - transF (WaitAtLeast 0) _ = (WaitForTransceivers, True ) - transF (WaitAtLeast n) _ = (WaitAtLeast (n - 1), True ) - transF WaitForTransceivers True = (SyncPulse False maxBound, False) - transF WaitForTransceivers _ = (WaitForTransceivers, True ) - transF (SyncPulse o 0) True = (SyncPulse (not o) maxBound, not o) - transF (SyncPulse o n) True = (SyncPulse o (n - 1), o ) - transF _ _ = (Failure, True ) + transF GettingReady _ = (WaitAtLeast maxBound, False) + transF (WaitAtLeast 0) True = (SyncPulse False maxBound, False) + transF (WaitAtLeast 0) _ = (WaitForTransceivers, True) + transF (WaitAtLeast n) _ = (WaitAtLeast (n - 1), True) + transF WaitForTransceivers True = (SyncPulse False maxBound, False) + transF WaitForTransceivers _ = (WaitForTransceivers, True) + transF (SyncPulse o 0) True = (SyncPulse (not o) maxBound, not o) + transF (SyncPulse o n) True = (SyncPulse o (n - 1), o) + transF _ _ = (Failure, True) -- | The state space of the Moore machine for recovering @SYNC_OUT@. -data SyncInRec dom = - WaitForStart +data SyncInRec dom + = WaitForStart | WaitForReady - | WaitForChange Bool + | WaitForChange + Bool (Index (Div (SyncPulseCycles dom) 10 + SyncPulseCycles dom)) deriving (Generic, NFDataX) -- | Recovers the activity cycle of a test as shared via @SYNC_OUT@. syncInRecover :: - forall dom. HasCallStack => - KnownDomain dom => + forall dom. + (HasCallStack) => + (KnownDomain dom) => Clock dom -> Reset dom -> + -- | The indicator for the test being started via the VIO interface. Signal dom Bool -> - -- ^ The indicator for the test being started via the VIO interface. + -- | The @SYNC_IN@ signal. Signal dom Bool -> - -- ^ The @SYNC_IN@ signal. - Signal dom (Bool, Bool) - -- ^ Returns two signals: The first one indicates that the + -- | Returns two signals: The first one indicates that the -- @SYNC_OUT@ signal generation has been initiated, while the second -- one indicates the synchronized start of the test. -syncInRecover clk rst = curry $ - moore clk rst enableGen transF out (WaitForStart :: SyncInRec dom) . bundle + Signal dom (Bool, Bool) +syncInRecover clk rst = + curry + $ moore clk rst enableGen transF out (WaitForStart :: SyncInRec dom) + . bundle where - transF _ (False, _ ) = WaitForStart - transF WaitForStart (_ , True) = WaitForReady - transF WaitForStart (_ , _ ) = WaitForStart - transF WaitForReady (_ , True) = WaitForReady - transF WaitForReady (_ , _ ) = WaitForChange False maxBound - transF (WaitForChange _ 0) (_ , True) = WaitForStart - transF (WaitForChange o n) (_ , i ) - | o == i = WaitForChange o (n - 1) - | otherwise = WaitForChange i maxBound - - out WaitForStart = (False, False) - out WaitForReady = (True, False) - out WaitForChange{} = (True, True ) + transF _ (False, _) = WaitForStart + transF WaitForStart (_, True) = WaitForReady + transF WaitForStart (_, _) = WaitForStart + transF WaitForReady (_, True) = WaitForReady + transF WaitForReady (_, _) = WaitForChange False maxBound + transF (WaitForChange _ 0) (_, True) = WaitForStart + transF (WaitForChange o n) (_, i) + | o == i = WaitForChange o (n - 1) + | otherwise = WaitForChange i maxBound + + out WaitForStart = (False, False) + out WaitForReady = (True, False) + out WaitForChange{} = (True, True) diff --git a/bittide-instances/src/Bittide/Instances/Hitl/LinkConfiguration.hs b/bittide-instances/src/Bittide/Instances/Hitl/LinkConfiguration.hs index 9aeefeaf0..7503a05d5 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/LinkConfiguration.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/LinkConfiguration.hs @@ -2,37 +2,37 @@ -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} +{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} --- | Tests whether the transceiver link setup matches with the --- configuration defined in 'Bittide.Instances.Hitl.Setup.fpgaSetup'. --- To this end, each node sends its own index to all of it's --- neighbours, which then verify that the result matches with the --- definition. -module Bittide.Instances.Hitl.LinkConfiguration - ( linkConfigurationTest - , tests - ) where +{- | Tests whether the transceiver link setup matches with the +configuration defined in 'Bittide.Instances.Hitl.Setup.fpgaSetup'. +To this end, each node sends its own index to all of it's +neighbours, which then verify that the result matches with the +definition. +-} +module Bittide.Instances.Hitl.LinkConfiguration ( + linkConfigurationTest, + tests, +) where -import Clash.Prelude (withClockResetEnable) import Clash.Explicit.Prelude import qualified Clash.Explicit.Prelude as E +import Clash.Prelude (withClockResetEnable) import qualified Data.Map.Strict as Map (fromList) import Bittide.Arithmetic.Time import Bittide.ClockControl.Si5395J -import Bittide.ClockControl.Si539xSpi (ConfigState(Error, Finished), si539xSpi) +import Bittide.ClockControl.Si539xSpi (ConfigState (Error, Finished), si539xSpi) import Bittide.ElasticBuffer (sticky) import Bittide.Instances.Domains import Bittide.Transceiver -import Bittide.Hitl (HitlTests, NoPostProcData(..), hitlVio) +import Bittide.Hitl (HitlTests, NoPostProcData (..), hitlVio) import Bittide.Instances.Hitl.Setup @@ -46,9 +46,10 @@ import Data.Maybe (fromMaybe, isJust) import qualified Bittide.Transceiver as Transceiver import qualified Bittide.Transceiver.ResetManager as ResetManager --- | Checks whether the received index matches with the corresponding --- entry in 'Bittide.Instances.Hitl.Setup.fpgaSetup' and sychronizes --- to the right clock domain accordingly. +{- | Checks whether the received index matches with the corresponding +entry in 'Bittide.Instances.Hitl.Setup.fpgaSetup' and sychronizes +to the right clock domain accordingly. +-} checkData :: forall n src dst. (KnownDomain src, KnownDomain dst, KnownNat n, 1 <= n, BitSize (Index n) <= 64) => @@ -64,9 +65,10 @@ checkData dstClk srcClk ready rx setup = match ma mb = fromMaybe False (ma .==. (zExtend . pack <$> mb)) zExtend = zeroExtend @_ @(BitSize (Index n)) @(64 - BitSize (Index n)) --- | Extracts the corresponding target FPGA index from --- 'Bittide.Instances.Hitl.Setup.fpgaSetup' according to the given --- link index and synchronizes it to the provided clock domain. +{- | Extracts the corresponding target FPGA index from +'Bittide.Instances.Hitl.Setup.fpgaSetup' according to the given +link index and synchronizes it to the provided clock domain. +-} expectedTargetIndex :: (KnownDomain src, KnownDomain dst) => Clock src -> @@ -79,23 +81,35 @@ expectedTargetIndex srcClk myIndex dstClk dstRst link = fmap ((!! link) . snd . (fpgaSetup !!)) <$> xpmCdcStable srcClk myIndex dstClk dstRst --- | Synchronizes the fixed FPGA index from some given source domain --- to the given target domain. Lossy synchronization is sufficient --- here, as the index is considered to be stable stable once the test --- has been started. +{- | Synchronizes the fixed FPGA index from some given source domain +to the given target domain. Lossy synchronization is sufficient +here, as the index is considered to be stable stable once the test +has been started. +-} xpmCdcStable :: - ( KnownDomain src, KnownDomain dst - , BitPack a, NFDataX a, 1 <= BitSize a, BitSize a <= 1024 + ( KnownDomain src + , KnownDomain dst + , BitPack a + , NFDataX a + , 1 <= BitSize a + , BitSize a <= 1024 ) => - Clock src -> Signal src a -> - Clock dst -> Reset dst -> Signal dst (Maybe a) + Clock src -> + Signal src a -> + Clock dst -> + Reset dst -> + Signal dst (Maybe a) xpmCdcStable srcClk idx dstClk dstRst = mIdx where - mIdx = register dstClk dstRst enableGen Nothing - $ (<|>) <$> xpmCdcMaybeLossy srcClk dstClk (pure <$> idx) <*> mIdx + mIdx = + register dstClk dstRst enableGen Nothing + $ (<|>) + <$> xpmCdcMaybeLossy srcClk dstClk (pure <$> idx) + <*> mIdx --- | Configures the clock boards, fires up all of the transceivers and --- observes the incoming links. +{- | Configures the clock boards, fires up all of the transceivers and +observes the incoming links. +-} transceiversStartAndObserve :: "SMA_MGT_REFCLK_C" ::: Clock Ext200 -> "SYSCLK" ::: Clock Basic125 -> @@ -110,11 +124,11 @@ transceiversStartAndObserve :: , "success" ::: Signal Basic125 Bool , "stats" ::: Vec LinkCount (Signal Basic125 ResetManager.Statistics) , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) transceiversStartAndObserve refClk sysClk rst myIndex rxNs rxPs miso = ( transceivers.txNs @@ -134,18 +148,26 @@ transceiversStartAndObserve refClk sysClk rst myIndex rxNs rxPs miso = spiErr = E.dflipflop sysClk $ isErr <$> spiState isErr = \case - Error {} -> True - _ -> False + Error{} -> True + _ -> False (_, _, spiState, spiOut) = - withClockResetEnable sysClk sysRst enableGen $ - si539xSpi testConfig6_200_on_0a_1ppb - (SNat @(Microseconds 10)) (pure Nothing) miso + withClockResetEnable sysClk sysRst enableGen + $ si539xSpi + testConfig6_200_on_0a_1ppb + (SNat @(Microseconds 10)) + (pure Nothing) + miso -- Transceiver setup transceivers = transceiverPrbsN - @GthTx @GthRx @Ext200 @Basic125 @GthTxS @GthRxS + @GthTx + @GthRx + @Ext200 + @Basic125 + @GthTxS + @GthRxS Transceiver.defConfig Transceiver.Inputs { clock = sysClk @@ -162,18 +184,24 @@ transceiversStartAndObserve refClk sysClk rst myIndex rxNs rxPs miso = -- synchronizes the FPGA's stable index to the individual TX clock -- domains of the transceivers - myIndexTxN = fmap (zeroExtend . pack . fromMaybe 0) - <$> zipWith (xpmCdcStable sysClk myIndex) - transceivers.txClocks - transceivers.txResets + myIndexTxN = + fmap (zeroExtend . pack . fromMaybe 0) + <$> zipWith + (xpmCdcStable sysClk myIndex) + transceivers.txClocks + transceivers.txResets -- check that all the received data matches with our expectations - success = fmap and $ bundle - $ zipWith4 (checkData @FpgaCount sysClk) + success = + fmap and + $ bundle + $ zipWith4 + (checkData @FpgaCount sysClk) transceivers.rxClocks transceivers.linkReadys transceivers.rxDatas - $ zipWith3 (expectedTargetIndex sysClk myIndex) + $ zipWith3 + (expectedTargetIndex sysClk myIndex) transceivers.rxClocks transceivers.rxResets indicesI @@ -190,11 +218,11 @@ linkConfigurationTest :: , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) linkConfigurationTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, syncOut, spiDone, spiOut) @@ -210,14 +238,15 @@ linkConfigurationTest refClkDiff sysClkDiff syncIn rxns rxps miso = -- use some simple SYNC_IN / SYNC_OUT synchronization to -- synchronously start the test syncInRst = - resetGlitchFilter (SNat @1024) sysClk - $ unsafeFromActiveLow - $ xpmCdcSingle sysClk sysClk syncIn + resetGlitchFilter (SNat @1024) sysClk + $ unsafeFromActiveLow + $ xpmCdcSingle sysClk sysClk syncIn syncOut = startTest - testRst = sysRst - `orReset` syncInRst - `orReset` unsafeFromActiveLow startTest + testRst = + sysRst + `orReset` syncInRst + `orReset` unsafeFromActiveLow startTest (txns, txps, allReady, success, _stats, spiDone, spiOut) = transceiversStartAndObserve refClk sysClk testRst myIndex rxns rxps miso @@ -231,9 +260,10 @@ linkConfigurationTest refClkDiff sysClkDiff syncIn rxns rxps miso = -- should be plenty. The test will stop immediately on success, -- i.e., if all neighbours have transmitted the expected ids -- alltogether at least once. - done = success - .||. failAfterUpSticky - .||. trueFor (SNat @(Seconds 40)) sysClk testRst allReady + done = + success + .||. failAfterUpSticky + .||. trueFor (SNat @(Seconds 40)) sysClk testRst allReady testConfig :: Signal Basic125 (Maybe (Index FpgaCount)) testConfig = hitlVio 0 sysClk done (success .&&. (not <$> failAfterUpSticky)) @@ -241,6 +271,7 @@ linkConfigurationTest refClkDiff sysClkDiff syncIn rxns rxps miso = makeTopEntity 'linkConfigurationTest tests :: HitlTests (Index FpgaCount) -tests = Map.fromList - [ ("LinkConfiguration", (toList $ zip indicesI indicesI, NoPostProcData)) - ] +tests = + Map.fromList + [ ("LinkConfiguration", (toList $ zip indicesI indicesI, NoPostProcData)) + ] diff --git a/bittide-instances/src/Bittide/Instances/Hitl/Post/BoardTestExtended.hs b/bittide-instances/src/Bittide/Instances/Hitl/Post/BoardTestExtended.hs index d2dd46c85..28bdc19a9 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/Post/BoardTestExtended.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/Post/BoardTestExtended.hs @@ -1,27 +1,26 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} --- | Post processing of ILA data for 'boardTestExtended', serves as an example --- of post processing. +{- | Post processing of ILA data for 'boardTestExtended', serves as an example +of post processing. +-} module Bittide.Instances.Hitl.Post.BoardTestExtended (postBoardTestExtended) where import Prelude import Data.Csv import Data.List (isSuffixOf) -import System.Exit (ExitCode(..)) -import Test.Tasty.HUnit +import System.Exit (ExitCode (..)) import System.FilePath +import Test.Tasty.HUnit import Bittide.Instances.Hitl.Post.PostProcess import qualified Data.ByteString.Lazy as BL import qualified Data.Vector as V - data Row = Row { sampleInBuffer :: Int , sampleInWindow :: Int @@ -31,19 +30,20 @@ data Row = Row , testStartB :: Bool , testDone :: Bool , testSuccess :: Bool - } deriving Show + } + deriving (Show) instance FromNamedRecord Row where - parseNamedRecord m = Row <$> - m .: "Sample in Buffer" <*> - m .: "Sample in Window" <*> - (toEnum <$> m .: "trigger_AorB") <*> - (toEnum <$> m .: "capture") <*> - (toEnum <$> m .: "ilaTestStartA") <*> - (toEnum <$> m .: "ilaTestStartB") <*> - (toEnum <$> m .: "ilaTestDone") <*> - (toEnum <$> m .: "ilaTestSuccess") - + parseNamedRecord m = + Row + <$> m .: "Sample in Buffer" + <*> m .: "Sample in Window" + <*> (toEnum <$> m .: "trigger_AorB") + <*> (toEnum <$> m .: "capture") + <*> (toEnum <$> m .: "ilaTestStartA") + <*> (toEnum <$> m .: "ilaTestStartB") + <*> (toEnum <$> m .: "ilaTestDone") + <*> (toEnum <$> m .: "ilaTestSuccess") assertTriggerAtStart :: [Row] -> Assertion assertTriggerAtStart rows = @@ -66,6 +66,9 @@ postBoardTestExtended _exitCode ilaCsvPaths = do csvToProcess = filter ((baseNameEndsWith "boardTestIla") . ilaName) ilaCsvPaths assertBool "Expected at least 1 CSV file, but got 0" $ not (null csvToProcess) mapM_ (processCsv . csvPath) csvToProcess - putStrLn $ "Successfully performed post processing of " <> show (length csvToProcess) <> " ILA CSV dumps" + putStrLn $ + "Successfully performed post processing of " + <> show (length csvToProcess) + <> " ILA CSV dumps" where baseNameEndsWith x = isSuffixOf x . takeBaseName diff --git a/bittide-instances/src/Bittide/Instances/Hitl/Post/PostProcess.hs b/bittide-instances/src/Bittide/Instances/Hitl/Post/PostProcess.hs index f3827c299..3dd9dc7d0 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/Post/PostProcess.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/Post/PostProcess.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE RecordWildCards #-} -- | Infrastructure for post processing of ILA data @@ -17,7 +16,6 @@ import Text.Read (readMaybe) import Data.Map (Map) import qualified Data.Map as Map - type TestName = String type IlaName = String @@ -35,20 +33,20 @@ data FlattenedIlaCsvPath = FlattenedIlaCsvPath , csvPath :: FilePath } - addIlaCsvPath :: NestedIlaCsvPaths -> FlattenedIlaCsvPath -> NestedIlaCsvPaths addIlaCsvPath m FlattenedIlaCsvPath{..} = Map.alter goTestName testName m where goTestName = Just . Map.alter goFpgaNum fpgaNum . fromMaybe Map.empty goFpgaNum = Just . Map.insert ilaName csvPath . fromMaybe Map.empty --- | Convert a String of the format "{idx}_{fpga_id}" to an FpgaNum. idx is --- either the index of the FPGA board in the demo rack, or 'X' if it was --- programmed with `Any`. fpga_id is the unique identifier of the FPGA. --- --- toFpgaNum "X_210308B09917" == Any --- toFpgaNum "7_210308B0B0C2" == DemoRack 7 -toFpgaNum :: HasCallStack => String -> FpgaNum +{- | Convert a String of the format "{idx}_{fpga_id}" to an FpgaNum. idx is +either the index of the FPGA board in the demo rack, or 'X' if it was +programmed with `Any`. fpga_id is the unique identifier of the FPGA. + +toFpgaNum "X_210308B09917" == Any +toFpgaNum "7_210308B0B0C2" == DemoRack 7 +-} +toFpgaNum :: (HasCallStack) => String -> FpgaNum toFpgaNum fpgaName = case prefix of "X" -> Any @@ -59,26 +57,33 @@ toFpgaNum fpgaName = where prefix = takeWhile (/= '_') fpgaName --- | Create NestedIlaCsvPaths using a list of filepaths of CSV dumps and the --- base directory of ILA data. -toNestedIlaCsvPaths :: HasCallStack => FilePath -> [FilePath] -> NestedIlaCsvPaths +{- | Create NestedIlaCsvPaths using a list of filepaths of CSV dumps and the +base directory of ILA data. +-} +toNestedIlaCsvPaths :: (HasCallStack) => FilePath -> [FilePath] -> NestedIlaCsvPaths toNestedIlaCsvPaths ilaDir = foldl addIlaCsvPath Map.empty . toFlattenedIlaCsvPathList ilaDir --- | Create a list of FlattenedIlaCsvPath using a list of filepaths of CSV dumps --- and the base directory of ILA data. -toFlattenedIlaCsvPathList :: HasCallStack => FilePath -> [FilePath] -> [FlattenedIlaCsvPath] +{- | Create a list of FlattenedIlaCsvPath using a list of filepaths of CSV dumps +and the base directory of ILA data. +-} +toFlattenedIlaCsvPathList :: + (HasCallStack) => FilePath -> [FilePath] -> [FlattenedIlaCsvPath] toFlattenedIlaCsvPathList ilaDir = map go - where - go :: FilePath -> FlattenedIlaCsvPath - go csvPath = FlattenedIlaCsvPath{..} - where - relativeCsvPath = makeRelative ilaDir csvPath - (testName, toFpgaNum -> fpgaNum, takeBaseName -> ilaName) = - case splitDirectories relativeCsvPath of - [a,b,c] -> (a,b,c) - zs -> error $ - "Execpted to split " <> show relativeCsvPath <> " in tree parts," <> - " but was able to split it into: " <> show zs + where + go :: FilePath -> FlattenedIlaCsvPath + go csvPath = FlattenedIlaCsvPath{..} + where + relativeCsvPath = makeRelative ilaDir csvPath + (testName, toFpgaNum -> fpgaNum, takeBaseName -> ilaName) = + case splitDirectories relativeCsvPath of + [a, b, c] -> (a, b, c) + zs -> + error $ + "Execpted to split " + <> show relativeCsvPath + <> " in tree parts," + <> " but was able to split it into: " + <> show zs -- | Like 'Map.!', but mentions key in error message if it can't be found get :: (HasCallStack, Ord k, Show k) => Map k v -> k -> v @@ -86,4 +91,5 @@ get m k = case Map.lookup k m of Just v -> v Nothing -> error $ "Could not find key: " <> show k + infixl 9 `get` diff --git a/bittide-instances/src/Bittide/Instances/Hitl/Setup.hs b/bittide-instances/src/Bittide/Instances/Hitl/Setup.hs index ad823ff84..c33522697 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/Setup.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/Setup.hs @@ -2,21 +2,21 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Bittide.Instances.Hitl.Setup - ( FpgaCount - , LinkCount - , TransceiverWires - , channelNames - , clockPaths - , fpgaSetup - , linkMask - , linkMasks - ) where +module Bittide.Instances.Hitl.Setup ( + FpgaCount, + LinkCount, + TransceiverWires, + channelNames, + clockPaths, + fpgaSetup, + linkMask, + linkMasks, +) where import Clash.Prelude import Bittide.Topology -import Data.Constraint ((:-)(..), Dict(..)) +import Data.Constraint (Dict (..), (:-) (..)) import Data.Constraint.Nat (leTrans) -- | The number of FPGAs in the current setup @@ -24,63 +24,70 @@ type FpgaCount = 8 :: Nat type LinkCount = FpgaCount - 1 --- | Data wires from/to transceivers. No logic should be inserted on these --- wires. Should be considered asynchronous to one another - even though their --- domain encodes them as related. +{- | Data wires from/to transceivers. No logic should be inserted on these +wires. Should be considered asynchronous to one another - even though their +domain encodes them as related. +-} type TransceiverWires dom n = Signal dom (BitVector n) channelNames :: Vec LinkCount String channelNames = - "X0Y10":> "X0Y9":> "X0Y16" :> "X0Y17" :> "X0Y18" :> "X0Y19" :> "X0Y11" :> Nil + "X0Y10" :> "X0Y9" :> "X0Y16" :> "X0Y17" :> "X0Y18" :> "X0Y19" :> "X0Y11" :> Nil clockPaths :: Vec LinkCount String clockPaths = - "clk0" :> "clk0":> "clk0-2":> "clk0-2":> "clk0-2":> "clk0-2":> "clk0" :> Nil + "clk0" :> "clk0" :> "clk0-2" :> "clk0-2" :> "clk0-2" :> "clk0-2" :> "clk0" :> Nil --- | Some order of the FPGA ids and a mapping to their connected --- neighbors (via the index position in the vector) according to the --- different hardware interfaces on the boards. +{- | Some order of the FPGA ids and a mapping to their connected +neighbors (via the index position in the vector) according to the +different hardware interfaces on the boards. +-} fpgaSetup :: Vec FpgaCount (String, Vec LinkCount (Index FpgaCount)) fpgaSetup = -- FPGA Id SFP0 SFP1 J4 J5 J6 J7 SMA - ( "210308B3B272", 3 :> 2 :> 4 :> 5 :> 6 :> 7 :> 1 :> Nil ) - :> ( "210308B0992E", 2 :> 3 :> 5 :> 6 :> 7 :> 4 :> 0 :> Nil ) - :> ( "210308B0AE73", 1 :> 0 :> 6 :> 7 :> 4 :> 5 :> 3 :> Nil ) - :> ( "210308B0AE6D", 0 :> 1 :> 7 :> 4 :> 5 :> 6 :> 2 :> Nil ) - :> ( "210308B0AFD4", 7 :> 6 :> 0 :> 3 :> 2 :> 1 :> 5 :> Nil ) - :> ( "210308B0AE65", 6 :> 7 :> 1 :> 0 :> 3 :> 2 :> 4 :> Nil ) - :> ( "210308B3A22D", 5 :> 4 :> 2 :> 1 :> 0 :> 3 :> 7 :> Nil ) - :> ( "210308B0B0C2", 4 :> 5 :> 3 :> 2 :> 1 :> 0 :> 6 :> Nil ) - :> Nil + ("210308B3B272", 3 :> 2 :> 4 :> 5 :> 6 :> 7 :> 1 :> Nil) + :> ("210308B0992E", 2 :> 3 :> 5 :> 6 :> 7 :> 4 :> 0 :> Nil) + :> ("210308B0AE73", 1 :> 0 :> 6 :> 7 :> 4 :> 5 :> 3 :> Nil) + :> ("210308B0AE6D", 0 :> 1 :> 7 :> 4 :> 5 :> 6 :> 2 :> Nil) + :> ("210308B0AFD4", 7 :> 6 :> 0 :> 3 :> 2 :> 1 :> 5 :> Nil) + :> ("210308B0AE65", 6 :> 7 :> 1 :> 0 :> 3 :> 2 :> 4 :> Nil) + :> ("210308B3A22D", 5 :> 4 :> 2 :> 1 :> 0 :> 3 :> 7 :> Nil) + :> ("210308B0B0C2", 4 :> 5 :> 3 :> 2 :> 1 :> 0 :> 6 :> Nil) + :> Nil --- | Determines the link mask of a particular node. --- --- >>> import Data.Graph --- >>> import Clash.Prelude --- >>> import Bittide.Topology --- >>> let edges = [(0, 1), (0, 2), (1, 2), (1, 0), (2, 0), (2, 1)] --- >>> let g = fromGraph @3 "test" $ buildG (0, 2) edges --- >>> linkMask g d0 --- 0b010_0001 --- >>> linkMask g d1 --- 0b100_0001 --- >>> linkMask g d2 --- 0b110_0000 +{- | Determines the link mask of a particular node. + +>>> import Data.Graph +>>> import Clash.Prelude +>>> import Bittide.Topology +>>> let edges = [(0, 1), (0, 2), (1, 2), (1, 0), (2, 0), (2, 1)] +>>> let g = fromGraph @3 "test" $ buildG (0, 2) edges +>>> linkMask g d0 +0b010_0001 +>>> linkMask g d1 +0b100_0001 +>>> linkMask g d2 +0b110_0000 +-} linkMask :: forall n i. (KnownNat n, KnownNat i, n <= FpgaCount, i + 1 <= n) => - Topology n -> SNat i -> BitVector (FpgaCount - 1) + Topology n -> + SNat i -> + BitVector (FpgaCount - 1) linkMask g i = case leTrans @(i + 1) @n @FpgaCount of Sub Dict -> pack $ map edge $ snd $ at @i @(FpgaCount - i - 1) i fpgaSetup where edge j = - j <= (natToNum @(n - 1)) - && hasEdge g (natToNum @i) (truncateB @_ @n @(FpgaCount - n) j) + j + <= (natToNum @(n - 1)) + && hasEdge g (natToNum @i) (truncateB @_ @n @(FpgaCount - n) j) linkMasks :: forall n. (KnownNat n, n <= FpgaCount) => - Topology n -> Vec n (BitVector (FpgaCount - 1)) + Topology n -> + Vec n (BitVector (FpgaCount - 1)) linkMasks g = smap (const . linkMask') indicesI where -- workaround, which is required to compensate for the missing upper @@ -88,6 +95,6 @@ linkMasks g = smap (const . linkMask') indicesI -- https://github.com/clash-lang/clash-compiler/pull/2686 -- is available. linkMask' :: forall i. SNat i -> BitVector (FpgaCount - 1) - linkMask' i@SNat = case compareSNat (SNat @(i + 1)) (SNat @n) of + linkMask' i@SNat = case compareSNat (SNat @(i + 1)) (SNat @n) of SNatLE -> linkMask g i _ -> error "impossible" diff --git a/bittide-instances/src/Bittide/Instances/Hitl/SyncInSyncOut.hs b/bittide-instances/src/Bittide/Instances/Hitl/SyncInSyncOut.hs index e7bdf08f9..12442e8bc 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/SyncInSyncOut.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/SyncInSyncOut.hs @@ -1,65 +1,64 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} --- | Test to confirm physical connection of SYNC_IN / SYNC_OUT. --- --- For some tests in Bittide is important that our demo rig (consisting of eight --- FPGA development boards) start their tests synchronously. To this end, we've --- wired up these boards as such (shown with just three): --- --- FPGA 0 --- +------------+ --- | SYNC_IN |<--------+ --- | | | --- | SYNC_OUT |--X | --- +------------+ | --- | --- FPGA 1 | --- +------------+ | --- | SYNC_IN |<--------| --- | | | --- | SYNC_OUT |--X | --- +------------+ | --- | --- FPGA 2 | --- +------------+ | --- | SYNC_IN |<--------+ --- | | | --- | SYNC_OUT |>--------+ --- +------------+ --- --- In this setup, all FPGAs can drive their SYNC_OUT to low as a default value --- while driving it to high as soon as the their tests starts. Because only the --- last FPGA has its SYNC_OUT physically connected, only its assertion will have --- effect. In the mean time, all FPGAs should monitor their SYNC_IN and start --- running when it gets asserted. As long as the last FPGA is the last to be --- started (through test VIOs), this will make FPGAs start their tests --- synchronously. --- --- This test therefore consists of two parts: --- --- * A component that drives SYNC_OUT low for 1 second, and high indefinitely. --- * A component that checks whether SYNC_IN is low for at least a second, and --- that it is asserted within 10 seconds thereafter. --- --- This gives the TCL ~9 seconds to program all the boards. --- --- Failure modes: --- --- 1. One or more SYNC_INs are *disconnected*. Boards will read either low or --- high indefinitely, failing the tests. Alternatively; if no pull up or --- pull down is available, results will be random - also failing the test. --- --- 2. None of the SYNC_OUTs are connected. Same result as (1). --- --- 3. Multiple SYNC_OUTs are connected. The last board in the chain will see --- the rising edge "too soon". --- --- 4. Wrong SYNC_OUT is connected. Same result as (3). --- +{- | Test to confirm physical connection of SYNC_IN / SYNC_OUT. + +For some tests in Bittide is important that our demo rig (consisting of eight +FPGA development boards) start their tests synchronously. To this end, we've +wired up these boards as such (shown with just three): + + FPGA 0 + +------------+ + | SYNC_IN |<--------+ + | | | + | SYNC_OUT |--X | + +------------+ | + | + FPGA 1 | + +------------+ | + | SYNC_IN |<--------| + | | | + | SYNC_OUT |--X | + +------------+ | + | + FPGA 2 | + +------------+ | + | SYNC_IN |<--------+ + | | | + | SYNC_OUT |>--------+ + +------------+ + +In this setup, all FPGAs can drive their SYNC_OUT to low as a default value +while driving it to high as soon as the their tests starts. Because only the +last FPGA has its SYNC_OUT physically connected, only its assertion will have +effect. In the mean time, all FPGAs should monitor their SYNC_IN and start +running when it gets asserted. As long as the last FPGA is the last to be +started (through test VIOs), this will make FPGAs start their tests +synchronously. + +This test therefore consists of two parts: + + * A component that drives SYNC_OUT low for 1 second, and high indefinitely. + * A component that checks whether SYNC_IN is low for at least a second, and + that it is asserted within 10 seconds thereafter. + +This gives the TCL ~9 seconds to program all the boards. + +Failure modes: + + 1. One or more SYNC_INs are *disconnected*. Boards will read either low or + high indefinitely, failing the tests. Alternatively; if no pull up or + pull down is available, results will be random - also failing the test. + + 2. None of the SYNC_OUTs are connected. Same result as (1). + + 3. Multiple SYNC_OUTs are connected. The last board in the chain will see + the rising edge "too soon". + + 4. Wrong SYNC_OUT is connected. Same result as (3). +-} module Bittide.Instances.Hitl.SyncInSyncOut where import Clash.Explicit.Prelude hiding (PeriodToCycles) @@ -84,46 +83,47 @@ data TestStatus -- | State for 'testFsm' data TestFsmState - = InReset - -- ^ Lie low for a bit - | ExpectLow (IndexSeconds 1) - -- ^ Expect _low_ for a least 1 second - | WaitForRising (IndexSeconds 10) - -- ^ Expect a rising edge within 10 seconds. The edge is expected after _time - -- it takes to start the remaining tests_. + = -- | Lie low for a bit + InReset + | -- | Expect _low_ for a least 1 second + ExpectLow (IndexSeconds 1) + | -- | Expect a rising edge within 10 seconds. The edge is expected after _time + -- it takes to start the remaining tests_. + WaitForRising (IndexSeconds 10) | Done TestStatus deriving (Generic, Show, ShowX, NFDataX) -- | State for 'genFsm' data GenFsmState - = GInReset - -- ^ Lie low for a bit - | GLow (IndexSeconds 1) - -- ^ Drive SYNC_OUT _low_ for exactly one second - | GHigh - -- ^ Drive SYNC_OUT _high_ indefinitely + = -- | Lie low for a bit + GInReset + | -- | Drive SYNC_OUT _low_ for exactly one second + GLow (IndexSeconds 1) + | -- | Drive SYNC_OUT _high_ indefinitely + GHigh deriving (Generic, Show, ShowX, NFDataX) -- | Check SYNC_IN. See Module documenation for more information. testFsm :: TestFsmState -> Bool -> (TestFsmState, TestStatus) -testFsm InReset _ = (ExpectLow maxBound, Busy) -testFsm (ExpectLow _) True = (Done Fail, Busy) -testFsm (ExpectLow 0) False = (WaitForRising maxBound, Busy) -testFsm (ExpectLow n) False = (ExpectLow (n - 1), Busy) -testFsm (WaitForRising _) True = (Done Success, Busy) -testFsm (WaitForRising 0) False = (Done Fail, Busy) -testFsm (WaitForRising n) False = (WaitForRising (n - 1), Busy) -testFsm s@(Done result) _ = (s, result) +testFsm InReset _ = (ExpectLow maxBound, Busy) +testFsm (ExpectLow _) True = (Done Fail, Busy) +testFsm (ExpectLow 0) False = (WaitForRising maxBound, Busy) +testFsm (ExpectLow n) False = (ExpectLow (n - 1), Busy) +testFsm (WaitForRising _) True = (Done Success, Busy) +testFsm (WaitForRising 0) False = (Done Fail, Busy) +testFsm (WaitForRising n) False = (WaitForRising (n - 1), Busy) +testFsm s@(Done result) _ = (s, result) -- | Generate SYNC_OUT. See Module documenation for more information. genFsm :: GenFsmState -> () -> (GenFsmState, Bool) genFsm GInReset _ = (GLow maxBound, False) -genFsm (GLow 0) _ = (GHigh, False) -genFsm (GLow n) _ = (GLow (n - 1), False) -genFsm GHigh _ = (GHigh, True) +genFsm (GLow 0) _ = (GHigh, False) +genFsm (GLow n) _ = (GLow (n - 1), False) +genFsm GHigh _ = (GHigh, True) --- | Convert a 'TestStatus' in to a pair of booleans @done@ and @success@. Used --- to communicate test status to host computer. +{- | Convert a 'TestStatus' in to a pair of booleans @done@ and @success@. Used +to communicate test status to host computer. +-} testStatusToDoneSuccess :: TestStatus -> (Bool, Bool) testStatusToDoneSuccess = \case Busy -> (False, False) @@ -140,20 +140,20 @@ syncInSyncOut sysClkDiff syncIn0 = syncOut (sysClk, sysRst) = clockWizardDifferential sysClkDiff noReset testRst = sysRst `orReset` unsafeFromActiveLow startTest syncIn1 = - unsafeToActiveHigh - $ resetGlitchFilter (SNat @1024) sysClk - $ unsafeFromActiveHigh - $ xpmCdcSingle sysClk sysClk syncIn0 + unsafeToActiveHigh + $ resetGlitchFilter (SNat @1024) sysClk + $ unsafeFromActiveHigh + $ xpmCdcSingle sysClk sysClk syncIn0 testStatus = mealy sysClk testRst enableGen testFsm InReset syncIn1 (testDone, testSuccess) = unbundle (testStatusToDoneSuccess <$> testStatus) syncOut = - delay sysClk enableGen False $ -- << filter glitches in output - mealy sysClk testRst enableGen genFsm GInReset (pure ()) - + delay sysClk enableGen False + $ mealy sysClk testRst enableGen genFsm GInReset (pure ()) -- << filter glitches in output startTest :: Signal Basic300 Bool startTest = hitlVioBool sysClk testDone testSuccess + makeTopEntity 'syncInSyncOut tests :: HitlTests () diff --git a/bittide-instances/src/Bittide/Instances/Hitl/Tcl/ExtraProbes.hs b/bittide-instances/src/Bittide/Instances/Hitl/Tcl/ExtraProbes.hs index 3db573d5b..feb3cf230 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/Tcl/ExtraProbes.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/Tcl/ExtraProbes.hs @@ -6,15 +6,17 @@ module Bittide.Instances.Hitl.Tcl.ExtraProbes where import Clash.Prelude import Bittide.Instances.Domains -import Clash.Annotations.TH ( makeTopEntity ) +import Clash.Annotations.TH (makeTopEntity) import Clash.Cores.Xilinx.Extra import Clash.Cores.Xilinx.Unisim.DnaPortE2 (simDna2) import Clash.Cores.Xilinx.VIO import Data.Maybe {-# NOINLINE extraProbesTest #-} --- | A circuit that verifies the correct behavior of the TCL infrastructure for --- setting extra probes in Hitl tests. + +{- | A circuit that verifies the correct behavior of the TCL infrastructure for +setting extra probes in Hitl tests. +-} extraProbesTest :: "CLK_125MHZ" ::: DiffClock Ext125 -> "success" ::: Signal Ext125 Bool @@ -27,19 +29,20 @@ extraProbesTest diffClk = testSuccess rst = unsafeFromActiveLow testStart fpgaId = withClockResetEnable clk rst enableGen $ readDnaPortE2I simDna2 (testStart, testState, extraProbe) = - unbundle $ - setName @"vioHitlt" $ - vioProbe - ("probe_test_done" :> "probe_test_success" :> "fpgaId" :> Nil) - ("probe_test_start" :> "testState" :> "extraProbe" :> Nil) - (False, SetDefaultProbes, maxBound) - clk - testDone - testSuccess - fpgaId - --- | Produce the test result based on the test state and the extra probe value. --- These values should correspond to the yaml configuration. + unbundle + $ setName @"vioHitlt" + $ vioProbe + ("probe_test_done" :> "probe_test_success" :> "fpgaId" :> Nil) + ("probe_test_start" :> "testState" :> "extraProbe" :> Nil) + (False, SetDefaultProbes, maxBound) + clk + testDone + testSuccess + fpgaId + +{- | Produce the test result based on the test state and the extra probe value. +These values should correspond to the yaml configuration. +-} testResult :: TestState -> BitVector 96 -> Maybe (BitVector 96) -> Bool testResult s extraProbe fpgaId = case (s, extraProbe) of (SetDefaultProbes, 0) -> True diff --git a/bittide-instances/src/Bittide/Instances/Hitl/Tests.hs b/bittide-instances/src/Bittide/Instances/Hitl/Tests.hs index 567e2dd2e..71349f0b0 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/Tests.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/Tests.hs @@ -1,29 +1,29 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -module Bittide.Instances.Hitl.Tests - ( HitlTest(..) - , hitlTests - ) where -import Bittide.Simulate.Config (SimConf) +module Bittide.Instances.Hitl.Tests ( + HitlTest (..), + hitlTests, +) where + import Bittide.Hitl (HitlTestsWithPostProcData, MayHavePostProcData) -import Clash.Prelude (BitPack, String, FilePath, show) +import Bittide.Simulate.Config (SimConf) +import Clash.Prelude (BitPack, FilePath, String, show) import Data.Aeson (ToJSON) -import qualified Bittide.Instances.Hitl.BoardTest as BoardTest -import qualified Bittide.Instances.Hitl.FincFdec as FincFdec -import qualified Bittide.Instances.Hitl.FullMeshHwCc as FullMeshHwCc -import qualified Bittide.Instances.Hitl.FullMeshSwCc as FullMeshSwCc -import qualified Bittide.Instances.Hitl.HwCcTopologies as HwCcTopologies +import qualified Bittide.Instances.Hitl.BoardTest as BoardTest +import qualified Bittide.Instances.Hitl.FincFdec as FincFdec +import qualified Bittide.Instances.Hitl.FullMeshHwCc as FullMeshHwCc +import qualified Bittide.Instances.Hitl.FullMeshSwCc as FullMeshSwCc +import qualified Bittide.Instances.Hitl.HwCcTopologies as HwCcTopologies import qualified Bittide.Instances.Hitl.LinkConfiguration as LinkConfiguration -import qualified Bittide.Instances.Hitl.SyncInSyncOut as SyncInSyncOut -import qualified Bittide.Instances.Hitl.Tcl.ExtraProbes as ExtraProbes -import qualified Bittide.Instances.Hitl.Transceivers as Transceivers -import qualified Bittide.Instances.Hitl.VexRiscv as VexRiscv +import qualified Bittide.Instances.Hitl.SyncInSyncOut as SyncInSyncOut +import qualified Bittide.Instances.Hitl.Tcl.ExtraProbes as ExtraProbes +import qualified Bittide.Instances.Hitl.Transceivers as Transceivers +import qualified Bittide.Instances.Hitl.VexRiscv as VexRiscv -- | Existential wrapper for tests with known Haskell types. data HitlTest where @@ -44,19 +44,19 @@ data HitlTest where hitlTests :: [HitlTest] hitlTests = [ -- tests with known Haskell types - knownType 'BoardTest.boardTestExtended BoardTest.testsExtended - , knownType 'BoardTest.boardTestSimple BoardTest.testsSimple - , knownType 'FincFdec.fincFdecTests FincFdec.tests - , knownType 'FullMeshHwCc.fullMeshHwCcTest FullMeshHwCc.tests - , knownType 'FullMeshHwCc.fullMeshHwCcWithRiscvTest FullMeshHwCc.tests - , knownType 'FullMeshSwCc.fullMeshSwCcTest FullMeshSwCc.tests - , knownType 'HwCcTopologies.hwCcTopologyTest HwCcTopologies.tests - , knownType 'LinkConfiguration.linkConfigurationTest LinkConfiguration.tests - , knownType 'SyncInSyncOut.syncInSyncOut SyncInSyncOut.tests - , knownType 'Transceivers.transceiversUpTest Transceivers.tests - , knownType 'VexRiscv.vexRiscvTest VexRiscv.tests - -- tests that are loaded from config files - , loadConfig 'ExtraProbes.extraProbesTest "extraProbesTest.yml" + knownType 'BoardTest.boardTestExtended BoardTest.testsExtended + , knownType 'BoardTest.boardTestSimple BoardTest.testsSimple + , knownType 'FincFdec.fincFdecTests FincFdec.tests + , knownType 'FullMeshHwCc.fullMeshHwCcTest FullMeshHwCc.tests + , knownType 'FullMeshHwCc.fullMeshHwCcWithRiscvTest FullMeshHwCc.tests + , knownType 'FullMeshSwCc.fullMeshSwCcTest FullMeshSwCc.tests + , knownType 'HwCcTopologies.hwCcTopologyTest HwCcTopologies.tests + , knownType 'LinkConfiguration.linkConfigurationTest LinkConfiguration.tests + , knownType 'SyncInSyncOut.syncInSyncOut SyncInSyncOut.tests + , knownType 'Transceivers.transceiversUpTest Transceivers.tests + , knownType 'VexRiscv.vexRiscvTest VexRiscv.tests + , -- tests that are loaded from config files + loadConfig 'ExtraProbes.extraProbesTest "extraProbesTest.yml" ] where knownType nm = KnownType (show nm) diff --git a/bittide-instances/src/Bittide/Instances/Hitl/Transceivers.hs b/bittide-instances/src/Bittide/Instances/Hitl/Transceivers.hs index 1abf02c35..e54547200 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/Transceivers.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/Transceivers.hs @@ -6,32 +6,31 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} - {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} --- | Test whether clock boards are configurable and transceiver links come --- online. This assumes to run on a fully connected mesh of 8 FPGAs. Also see --- 'c_CHANNEL_NAMES' and 'c_CLOCK_PATHS'. It has two tricks up its sleeve: --- --- 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming --- its clock boards at the same time. --- --- 2. It keeps track of how many times the GTH's reset manager had to reset --- the connection and how often it lost connections after establishing --- them. --- --- This test will succeed if all links have been up for ten seconds. --- +{- | Test whether clock boards are configurable and transceiver links come +online. This assumes to run on a fully connected mesh of 8 FPGAs. Also see +'c_CHANNEL_NAMES' and 'c_CLOCK_PATHS'. It has two tricks up its sleeve: + + 1. It uses @SYNC_IN@/@SYNC_OUT@ to make sure each board starts programming + its clock boards at the same time. + + 2. It keeps track of how many times the GTH's reset manager had to reset + the connection and how often it lost connections after establishing + them. + +This test will succeed if all links have been up for ten seconds. +-} module Bittide.Instances.Hitl.Transceivers where -import Clash.Prelude (withClockResetEnable) import Clash.Explicit.Prelude +import Clash.Prelude (withClockResetEnable) import Bittide.Arithmetic.Time import Bittide.ClockControl.Si5395J import Bittide.ClockControl.Si539xSpi import Bittide.ElasticBuffer (sticky) -import Bittide.Hitl (HitlTests, NoPostProcData(..), FpgaIndex, hitlVio) +import Bittide.Hitl (FpgaIndex, HitlTests, NoPostProcData (..), hitlVio) import Bittide.Instances.Domains import Bittide.Instances.Hitl.Setup import Bittide.Transceiver @@ -48,33 +47,41 @@ import qualified Data.List as L import qualified Data.Map as Map import qualified Data.Text as Text --- | Start value of the counters used in 'counter' and 'expectCounter'. This is --- a non-zero start value, as a regression test for a bug where the transceivers --- would not come up if the counters started at zero. +{- | Start value of the counters used in 'counter' and 'expectCounter'. This is +a non-zero start value, as a regression test for a bug where the transceivers +would not come up if the counters started at zero. +-} counterStart :: BitVector 64 counterStart = 0xDEAD_BEEF_CA55_E77E -- | A counter starting at 'counterStart' -counter :: KnownDomain dom => Clock dom -> Reset dom -> Signal dom Bool -> Signal dom (BitVector 64) +counter :: + (KnownDomain dom) => + Clock dom -> + Reset dom -> + Signal dom Bool -> + Signal dom (BitVector 64) counter clk rst ena = let c = register clk rst (toEnable ena) counterStart (c + 1) in c --- | Expect a counter starting at 'counterStart' and incrementing by one on each --- cycle. +{- | Expect a counter starting at 'counterStart' and incrementing by one on each +cycle. +-} expectCounter :: - KnownDomain dom => + (KnownDomain dom) => Clock dom -> Reset dom -> + -- | Received data Signal dom (Maybe (BitVector 64)) -> - -- ^ Received data + -- | Error Signal dom Bool - -- ^ Error expectCounter clk rst = sticky clk rst . mealy clk rst enableGen go counterStart where go c (Just e) = (c + 1, c /= e) - go c Nothing = (c, False) + go c Nothing = (c, False) --- | Worker function for 'transceiversUpTest'. See module documentation for more --- information. +{- | Worker function for 'transceiversUpTest'. See module documentation for more +information. +-} goTransceiversUpTest :: Signal Basic125 FpgaIndex -> "SMA_MGT_REFCLK_C" ::: Clock Ext200 -> @@ -89,11 +96,11 @@ goTransceiversUpTest :: , "anyErrors" ::: Signal Basic125 Bool , "stats" ::: Vec LinkCount (Signal Basic125 ResetManager.Statistics) , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) goTransceiversUpTest fpgaIndex refClk sysClk rst rxNs rxPs miso = ( transceivers.txNs @@ -110,15 +117,15 @@ goTransceiversUpTest fpgaIndex refClk sysClk rst rxNs rxPs miso = sysRst = orReset rst (unsafeFromActiveLow (fmap not spiErr)) -- Clock programming - spiDone = E.dflipflop sysClk $ (==Finished) <$> spiState + spiDone = E.dflipflop sysClk $ (== Finished) <$> spiState spiErr = E.dflipflop sysClk $ isErr <$> spiState isErr (Error _) = True - isErr _ = False + isErr _ = False (_, _, spiState, spiOut) = - withClockResetEnable sysClk sysRst enableGen $ - si539xSpi testConfig6_200_on_0a_1ppb (SNat @(Microseconds 10)) (pure Nothing) miso + withClockResetEnable sysClk sysRst enableGen + $ si539xSpi testConfig6_200_on_0a_1ppb (SNat @(Microseconds 10)) (pure Nothing) miso -- Transceiver setup gthAllReset = unsafeFromActiveLow spiDone @@ -139,15 +146,20 @@ goTransceiversUpTest fpgaIndex refClk sysClk rst rxNs rxPs miso = transceivers.rxDatas expectCounterErrorSys = - fmap and - $ bundle - $ zipWith (.&&.) transceivers.linkUps - $ zipWith (`xpmCdcSingle` sysClk) transceivers.rxClocks expectCounterError + fmap and + $ bundle + $ zipWith (.&&.) transceivers.linkUps + $ zipWith (`xpmCdcSingle` sysClk) transceivers.rxClocks expectCounterError transceivers = transceiverPrbsN - @GthTx @GthRx @Ext200 @Basic125 @GthTxS @GthRxS - defConfig{debugIla=True, debugFpgaIndex=bitCoerce <$> fpgaIndex} + @GthTx + @GthRx + @Ext200 + @Basic125 + @GthTxS + @GthRxS + defConfig{debugIla = True, debugFpgaIndex = bitCoerce <$> fpgaIndex} Inputs { clock = sysClk , reset = gthAllReset @@ -173,11 +185,11 @@ transceiversUpTest :: , "GTH_TX_PS" ::: TransceiverWires GthTxS LinkCount , "SYNC_OUT" ::: Signal Basic125 Bool , "spiDone" ::: Signal Basic125 Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool - ) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) ) transceiversUpTest refClkDiff sysClkDiff syncIn rxns rxps miso = (txns, txps, syncOut, spiDone, spiOut) @@ -189,9 +201,9 @@ transceiversUpTest refClkDiff sysClkDiff syncIn rxns rxps miso = testRst = sysRst `orReset` unsafeFromActiveLow startTest `orReset` syncInRst syncOut = startTest syncInRst = - resetGlitchFilter (SNat @1024) sysClk - $ unsafeFromActiveLow - $ xpmCdcSingle sysClk sysClk syncIn + resetGlitchFilter (SNat @1024) sysClk + $ unsafeFromActiveLow + $ xpmCdcSingle sysClk sysClk syncIn (txns, txps, allUp, anyErrors, _stats, spiDone, spiOut) = goTransceiversUpTest fpgaIndex refClk sysClk testRst rxns rxps miso @@ -207,20 +219,19 @@ transceiversUpTest refClkDiff sysClkDiff syncIn rxns rxps miso = hitlVio 0 sysClk - -- Consider test done if links have been up consistently for 40 seconds. This -- is just below the test timeout of 60 seconds, so transceivers have ~20 -- seconds to come online reliably. This should be plenty. (trueFor (SNat @(Seconds 40)) sysClk testRst allUp .||. failAfterUpSticky .||. anyErrors) - -- Success? (fmap not failAfterUpSticky .&&. fmap not anyErrors) + makeTopEntity 'transceiversUpTest tests :: HitlTests FpgaIndex tests = Map.fromList testsAsList where - fpgaIndices = [0..] + fpgaIndices = [0 ..] nTests = 1 - testNames = ["T" <> Text.pack (show n) | n <- [(0::Int)..nTests-1]] + testNames = ["T" <> Text.pack (show n) | n <- [(0 :: Int) .. nTests - 1]] testsAsList = [(nm, (L.zip fpgaIndices fpgaIndices, NoPostProcData)) | nm <- testNames] diff --git a/bittide-instances/src/Bittide/Instances/Hitl/VexRiscv.hs b/bittide-instances/src/Bittide/Instances/Hitl/VexRiscv.hs index c03877cf0..b53e47c24 100644 --- a/bittide-instances/src/Bittide/Instances/Hitl/VexRiscv.hs +++ b/bittide-instances/src/Bittide/Instances/Hitl/VexRiscv.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} @@ -12,8 +12,8 @@ module Bittide.Instances.Hitl.VexRiscv where import Clash.Annotations.TH (makeTopEntity) -import Clash.Prelude import Clash.Explicit.Prelude (noReset, orReset) +import Clash.Prelude import Clash.Cores.UART (ValidBaud) import Clash.Xilinx.ClockGen (clockWizardDifferential) @@ -37,7 +37,7 @@ type UartRx = Bit type UartTx = Bit vexRiscvInner :: - forall dom . + forall dom. ( HiddenClockResetEnable dom , 1 <= DomainPeriod dom , ValidBaud dom 921600 @@ -53,61 +53,65 @@ vexRiscvInner jtagIn0 uartRx = , jtagOut , uartTx ) - where - stateToDoneSuccess Running = (False, False) - stateToDoneSuccess Success = (True, True) - stateToDoneSuccess Fail = (True, False) - - ((_, 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 + where + stateToDoneSuccess Running = (False, False) + stateToDoneSuccess Success = (True, True) + stateToDoneSuccess Fail = (True, False) + + ((_, 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 @@ -116,33 +120,32 @@ vexRiscvTest :: "CLK_125MHZ" ::: DiffClock Ext125 -> "JTAG" ::: Signal Basic125 JtagIn -> "USB_UART_TXD" ::: Signal Basic125 UartRx -> - "" ::: - ( "done" ::: Signal Basic125 TestDone - , "success" ::: Signal Basic125 TestSuccess - , "JTAG" ::: Signal Basic125 JtagOut - , "USB_UART_RXD" ::: Signal Basic125 UartTx - ) + "" + ::: ( "done" ::: Signal Basic125 TestDone + , "success" ::: Signal Basic125 TestSuccess + , "JTAG" ::: Signal Basic125 JtagOut + , "USB_UART_RXD" ::: Signal Basic125 UartTx + ) vexRiscvTest diffClk jtagIn uartRx = (testDone, testSuccess, jtagOut, uartTx) - where - (clk, clkStableRst) = clockWizardDifferential diffClk noReset - - (_, jtagOut, uartTx) = - withClockResetEnable clk reset enableGen (vexRiscvInner @Basic125 jtagIn uartRx) + where + (clk, clkStableRst) = clockWizardDifferential diffClk noReset - reset = orReset clkStableRst (unsafeFromActiveLow testStarted) + (_, jtagOut, uartTx) = + withClockResetEnable clk reset enableGen (vexRiscvInner @Basic125 jtagIn uartRx) - testStarted :: Signal Basic125 Bool - testStarted = hitlVioBool clk testDone testSuccess + reset = orReset clkStableRst (unsafeFromActiveLow testStarted) - -- TODO: We used to perform a HITL test where the CPU would write to a success - -- register (or a failure register when it would get trapped). We - -- currently load programs over JTAG instead of preloading them in the - -- bitstream, making this impossible to do. We should add a _pre_ - -- processing step to the HITL infrastructure, restoring the ability to - -- do this once more. - testDone = testStarted - testSuccess = testStarted + testStarted :: Signal Basic125 Bool + testStarted = hitlVioBool clk testDone testSuccess + -- TODO: We used to perform a HITL test where the CPU would write to a success + -- register (or a failure register when it would get trapped). We + -- currently load programs over JTAG instead of preloading them in the + -- bitstream, making this impossible to do. We should add a _pre_ + -- processing step to the HITL infrastructure, restoring the ability to + -- do this once more. + testDone = testStarted + testSuccess = testStarted {-# NOINLINE vexRiscvTest #-} makeTopEntity 'vexRiscvTest diff --git a/bittide-instances/src/Bittide/Instances/Pnr/Calendar.hs b/bittide-instances/src/Bittide/Instances/Pnr/Calendar.hs index 73ea973af..d099d80c6 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/Calendar.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/Calendar.hs @@ -18,27 +18,28 @@ import Bittide.Instances.Hacks (reducePins) type WishboneWidth = 4 type WishboneAddrWidth = 32 - switchCalendar1k :: - Clock Basic200 -> Reset Basic200 -> + Clock Basic200 -> + Reset Basic200 -> Signal Basic200 (WishboneM2S WishboneAddrWidth WishboneWidth (Bytes WishboneWidth)) -> ( Signal Basic200 (Vec 15 (CrossbarIndex 15)) - , Signal Basic200 Bool, Signal Basic200 (WishboneS2M (Bytes WishboneWidth)) + , Signal Basic200 Bool + , Signal Basic200 (WishboneS2M (Bytes WishboneWidth)) ) switchCalendar1k clk rst = - withClockResetEnable clk syncRst enableGen $ - mkCalendar (CalendarConfig (SNat @1024) cal cal) + withClockResetEnable clk syncRst enableGen + $ mkCalendar (CalendarConfig (SNat @1024) cal cal) where syncRst = resetSynchronizer clk rst - cal = ValidEntry{veEntry =repeat 0, veRepeat = 0 :: Unsigned 8} :> Nil - + cal = ValidEntry{veEntry = repeat 0, veRepeat = 0 :: Unsigned 8} :> Nil {-# NOINLINE switchCalendar1k #-} switchCalendar1kReducedPins :: - Clock Basic200 -> Reset Basic200 -> + Clock Basic200 -> + Reset Basic200 -> Signal Basic200 Bit -> Signal Basic200 Bit switchCalendar1kReducedPins clk rst = - withClock clk $ - reducePins (bundle . switchCalendar1k clk rst) + withClock clk + $ reducePins (bundle . switchCalendar1k clk rst) {-# NOINLINE switchCalendar1kReducedPins #-} diff --git a/bittide-instances/src/Bittide/Instances/Pnr/ClockControl.hs b/bittide-instances/src/Bittide/Instances/Pnr/ClockControl.hs index dc3bc53f3..b6dc87ef9 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/ClockControl.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/ClockControl.hs @@ -6,9 +6,9 @@ module Bittide.Instances.Pnr.ClockControl where import Clash.Prelude +import Bittide.ClockControl import Bittide.ClockControl.Callisto import Bittide.Instances.Domains -import Bittide.ClockControl config :: ClockControlConfig Basic200 12 8 1500000 config = $(lift (defClockConfig @Basic200)) diff --git a/bittide-instances/src/Bittide/Instances/Pnr/Counter.hs b/bittide-instances/src/Bittide/Instances/Pnr/Counter.hs index a0d66b81b..5050bed28 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/Counter.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/Counter.hs @@ -12,8 +12,10 @@ import Bittide.Instances.Domains import Bittide.Instances.Hacks counter :: - Clock Basic200 -> Reset Basic200 -> - Clock Basic200 -> Reset Basic200 -> + Clock Basic200 -> + Reset Basic200 -> + Clock Basic200 -> + Reset Basic200 -> Signal Basic200 () -> Signal Basic200 (Signed 32, Bool) counter clk0 rst0 clk1 rst1 _ = @@ -21,5 +23,5 @@ counter clk0 rst0 clk1 rst1 _ = counterReducedPins :: Clock Basic200 -> Signal Basic200 Bit counterReducedPins clk = - withClock clk $ - reducePins (counter clk noReset clk noReset) (pure 0) + withClock clk + $ reducePins (counter clk noReset clk noReset) (pure 0) diff --git a/bittide-instances/src/Bittide/Instances/Pnr/ElasticBuffer.hs b/bittide-instances/src/Bittide/Instances/Pnr/ElasticBuffer.hs index 5128d4ae5..ef97257de 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/ElasticBuffer.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/ElasticBuffer.hs @@ -5,18 +5,18 @@ module Bittide.Instances.Pnr.ElasticBuffer where -import Clash.Prelude import Clash.Annotations.TH +import Clash.Prelude -import Bittide.ElasticBuffer import Bittide.ClockControl (RelDataCount) +import Bittide.ElasticBuffer -createDomain vXilinxSystem{vPeriod=hzToPeriod 201e6, vName="Fast"} -createDomain vXilinxSystem{vPeriod=hzToPeriod 199e6, vName="Slow"} +createDomain vXilinxSystem{vPeriod = hzToPeriod 201e6, vName = "Fast"} +createDomain vXilinxSystem{vPeriod = hzToPeriod 199e6, vName = "Slow"} elasticBuffer5 :: "clkReadFast" ::: Clock Fast -> - "clkWriteSlow" :::Clock Slow -> + "clkWriteSlow" ::: Clock Slow -> "resetRead" ::: Reset Fast -> "writeData" ::: Signal Slow (Unsigned 8) -> ( "dataCount" ::: Signal Fast (RelDataCount 5) diff --git a/bittide-instances/src/Bittide/Instances/Pnr/Ethernet.hs b/bittide-instances/src/Bittide/Instances/Pnr/Ethernet.hs index 031385572..7d730df30 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/Ethernet.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/Ethernet.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# OPTIONS -fplugin=Protocols.Plugin #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} + module Bittide.Instances.Pnr.Ethernet where import Clash.Explicit.Prelude -import Clash.Prelude (withClockResetEnable, HiddenClockResetEnable) import Clash.Explicit.Reset.Extra +import Clash.Prelude (HiddenClockResetEnable, withClockResetEnable) import Clash.Cores.UART (ValidBaud) import Clash.Cores.Xilinx.Ethernet.Gmii @@ -31,20 +31,22 @@ type Baud = 921_600 baud :: SNat Baud baud = SNat --- | Instance containing: --- * VexRiscv CPU --- * UART --- * Free running timer --- * GPIO --- * Ethernet MAC +{- | Instance containing: +* VexRiscv CPU +* UART +* Free running timer +* GPIO +* Ethernet MAC +-} vexRiscGmii :: - forall logic rx tx gpioWidth . + forall logic rx tx gpioWidth. ( KnownDomain logic , KnownDomain rx , KnownDomain tx , KnownNat (DomainPeriod logic) , 1 <= DomainPeriod logic - , ValidBaud logic 921600) => + , ValidBaud logic 921600 + ) => SNat gpioWidth -> Clock logic -> Reset logic -> @@ -52,37 +54,50 @@ vexRiscGmii :: Reset rx -> Clock tx -> Reset tx -> - ( Signal logic Bit - , Signal rx Gmii - , Signal logic JtagIn - ) -> - ( Signal logic Bit - , Signal tx Gmii - , Signal logic JtagOut - , Signal logic (BitVector gpioWidth) - ) + ( Signal logic Bit + , Signal rx Gmii + , Signal logic JtagIn + ) -> + ( Signal logic Bit + , Signal tx Gmii + , Signal logic JtagOut + , Signal logic (BitVector gpioWidth) + ) vexRiscGmii SNat sysClk sysRst rxClk rxRst txClk txRst fwd = - (\((_,_,jtagBwd),(uartFwd, gmiiFwd, gpioFwd)) -> (uartFwd, gmiiFwd, jtagBwd, gpioFwd)) $ toSignals ( - circuit $ \(uartTx, gmiiRx, jtag) -> do - [uartBus, timeBus, wbAxiRx, wbAxiTx, macWb, gpioWb] <- pe -< jtag - (uartRx, _uartStatus) <- uart -< (uartBus, uartTx) - time -< timeBus - macStatIf -< (macWb, macStatus) - gpioDf <- idleSource -< () - gpioOut <- gpio -< (gpioWb, gpioDf) - - (axiRx0, gmiiTx, macStatus) <- mac -< (axiTx1, gmiiRx) - axiRx1 <- axiRxPipe -< axiRx0 - axiTx0 <- wbToAxiTx' -< wbAxiTx - axiTx1 <- axiTxPipe -< axiTx0 - _rxBufStatus <- wbAxiRxBuffer -< (wbAxiRx, axiRx1) - - idC -< (uartRx, gmiiTx, gpioOut) - ) (fwd, (pure (), pure (), pure ())) - + (\((_, _, jtagBwd), (uartFwd, gmiiFwd, gpioFwd)) -> (uartFwd, gmiiFwd, jtagBwd, gpioFwd)) + $ toSignals + ( circuit $ \(uartTx, gmiiRx, jtag) -> do + [uartBus, timeBus, wbAxiRx, wbAxiTx, macWb, gpioWb] <- pe -< jtag + (uartRx, _uartStatus) <- uart -< (uartBus, uartTx) + time -< timeBus + macStatIf -< (macWb, macStatus) + gpioDf <- idleSource -< () + gpioOut <- gpio -< (gpioWb, gpioDf) + + (axiRx0, gmiiTx, macStatus) <- mac -< (axiTx1, gmiiRx) + axiRx1 <- axiRxPipe -< axiRx0 + axiTx0 <- wbToAxiTx' -< wbAxiTx + axiTx1 <- axiTxPipe -< axiTx0 + _rxBufStatus <- wbAxiRxBuffer -< (wbAxiRx, axiRx1) + + idC -< (uartRx, gmiiTx, gpioOut) + ) + (fwd, (pure (), pure (), pure ())) where time = wcre timeWb - mac = ethMac1GFifoC (SNat @1500) (SNat @1500) sysClk sysRst txClk txRst rxClk rxRst miiSel txClkEna rxClkEna + mac = + ethMac1GFifoC + (SNat @1500) + (SNat @1500) + sysClk + sysRst + txClk + txRst + rxClk + rxRst + miiSel + txClkEna + rxClkEna macStatIf = wcre $ macStatusInterfaceWb d16 uart = wcre uartWb d32 d2 baud pe = wcre processingElement peConfig @@ -94,27 +109,28 @@ vexRiscGmii SNat sysClk sysRst rxClk rxRst txClk txRst fwd = miiSel = pure False rxClkEna = pure True txClkEna = pure True - wcre :: ((HiddenClockResetEnable logic => a) -> a) + wcre :: (((HiddenClockResetEnable logic) => a) -> a) wcre = withClockResetEnable sysClk sysRst enableGen peConfig = - PeConfig (0b100 :> 0b001 :> 0b010 :> 0b011 :> 0b101 :> 0b110 :> 0b111 :> 0b000 :> Nil) - (Undefined @(256 * 1024)) - (Undefined @(64 * 1024)) + PeConfig + (0b100 :> 0b001 :> 0b010 :> 0b011 :> 0b101 :> 0b110 :> 0b111 :> 0b000 :> Nil) + (Undefined @(256 * 1024)) + (Undefined @(64 * 1024)) vexRiscEthernet :: Clock Basic125B -> Reset Basic125B -> DiffClock Basic625 -> - ( Signal Basic125B JtagIn - , Signal Basic125B Bit - , Signal Basic625 Lvds - ) -> - ( Signal Basic125B JtagOut - , Signal Basic125B Bit - , Signal Basic625 Lvds - , Signal Basic125B (BitVector 32) - ) + ( Signal Basic125B JtagIn + , Signal Basic125B Bit + , Signal Basic625 Lvds + ) -> + ( Signal Basic125B JtagOut + , Signal Basic125B Bit + , Signal Basic625 Lvds + , Signal Basic125B (BitVector 32) + ) vexRiscEthernet sysClk sysRst sgmiiPhyClk (jtagin, uartIn, sgmiiIn) = (jtagOut, uartOut, bridgeLvdsOut, gpioOut) where @@ -122,7 +138,14 @@ vexRiscEthernet sysClk sysRst sgmiiPhyClk (jtagin, uartIn, sgmiiIn) = signalDetect = pure True anRestart = pure False conf = pure def{cAutoNegEnable = True} - anConf = pure def{cAcknowledge=True, cDuplexMode = FullDuplex, cLinkSpeed = Speed1000, cPhyLinkStatus = True} + anConf = + pure + def + { cAcknowledge = True + , cDuplexMode = FullDuplex + , cLinkSpeed = Speed1000 + , cPhyLinkStatus = True + } bridge = gmiiSgmiiBridge sgmiiPhyClk bridgeRst signalDetect conf anConf anRestart rxClk = bridgeClk125 :: Clock Basic125A rxRst = bridgeRst125 @@ -133,53 +156,65 @@ vexRiscEthernetTop :: "CLK_300MHZ" ::: DiffClock Ext300 -> "CPU_RESET" ::: Reset Ext300 -> "sgmii_phyclk" ::: DiffClock Basic625 -> - ( "JTAG" ::: Signal Basic125B JtagIn - , "USB_UART_TXD" ::: Signal Basic125B Bit - , "sgmii_rx" ::: Signal Basic625 Lvds - ) -> - ( "JTAG" ::: Signal Basic125B JtagOut - , "USB_UART_RXD" ::: Signal Basic125B Bit - , "sgmii_tx" ::: Signal Basic625 Lvds - ) -vexRiscEthernetTop diffClk cpuReset sgmiiClk inp = (j, u , s) + ( "JTAG" ::: Signal Basic125B JtagIn + , "USB_UART_TXD" ::: Signal Basic125B Bit + , "sgmii_rx" ::: Signal Basic625 Lvds + ) -> + ( "JTAG" ::: Signal Basic125B JtagOut + , "USB_UART_RXD" ::: Signal Basic125B Bit + , "sgmii_tx" ::: Signal Basic625 Lvds + ) +vexRiscEthernetTop diffClk cpuReset sgmiiClk inp = (j, u, s) where (sysClk, sysRst) = clockWizardDifferential diffClk cpuReset (j, u, s, _) = vexRiscEthernet sysClk sysRst sgmiiClk inp - -{-# ANN vexRiscEthernetTop (Synthesize - { t_name = "vexRiscEthernet" - , t_inputs = [ PortProduct "CLK_125MHZ" - [PortName "P", PortName "N"] - , PortName "CPU_RESET" - , PortProduct "SGMIICLK" - [PortName "P", PortName "N"] - , PortProduct "" - [ PortProduct "JTAG" - [ PortName "TCK", PortName "TMS", PortName "TDI"] - , PortName "USB_UART_TX" - , PortProduct "SGMII" - [ PortName "RX_P", PortName "RX_N"] - ] +{-# ANN + vexRiscEthernetTop + ( Synthesize + { t_name = "vexRiscEthernet" + , t_inputs = + [ PortProduct + "CLK_125MHZ" + [PortName "P", PortName "N"] + , PortName "CPU_RESET" + , PortProduct + "SGMIICLK" + [PortName "P", PortName "N"] + , PortProduct + "" + [ PortProduct + "JTAG" + [PortName "TCK", PortName "TMS", PortName "TDI"] + , PortName "USB_UART_TX" + , PortProduct + "SGMII" + [PortName "RX_P", PortName "RX_N"] + ] + ] + , t_output = + PortProduct + "" + [ PortProduct + "JTAG" + [ PortName "TDO" + , PortName "RST" ] - , t_output = - PortProduct "" - [ PortProduct "JTAG" - [ PortName "TDO" - , PortName "RST" - ] - , PortName "USB_UART_RX" - , PortProduct "SGMII" - [PortName "TX_P", PortName "TX_N"] - ] - }) #-} - - --- | Take a synchronous reset from one domain and convert it to an asynchronous reset. --- This inserts a register in the source domain to prevent glitching and then converts the domain. --- Note that the target domain is merely an implementation detail imposed by the digital --- abstraction. The resulting reset is not synchronous to the target domain. + , PortName "USB_UART_RX" + , PortProduct + "SGMII" + [PortName "TX_P", PortName "TX_N"] + ] + } + ) + #-} + +{- | Take a synchronous reset from one domain and convert it to an asynchronous reset. +This inserts a register in the source domain to prevent glitching and then converts the domain. +Note that the target domain is merely an implementation detail imposed by the digital +abstraction. The resulting reset is not synchronous to the target domain. +-} unsafeResetDesynchronizer :: - forall domA domS . + forall domA domS. (KnownDomain domA, KnownDomain domS, HasSynchronousReset domS, HasAsynchronousReset domA) => -- | Clock in the source domain Clock domS -> @@ -188,10 +223,11 @@ unsafeResetDesynchronizer :: -- | Asynchronous reset in the "target" domain Reset domA unsafeResetDesynchronizer clkIn = - unsafeFromActiveHigh . - unsafeSynchronizer clkIn clockGen . - unsafeToActiveHigh . - delayReset Asserted clkIn - -- unsafeSynchronizer needs a clock in the target domain for simulation purposes, we - -- can only use clockGen here because the black box of unsafeSynchronizer does - -- not use the clock (it becomes a wire in the generated HDL). + unsafeFromActiveHigh + . unsafeSynchronizer clkIn clockGen + . unsafeToActiveHigh + . delayReset Asserted clkIn + +-- unsafeSynchronizer needs a clock in the target domain for simulation purposes, we +-- can only use clockGen here because the black box of unsafeSynchronizer does +-- not use the clock (it becomes a wire in the generated HDL). diff --git a/bittide-instances/src/Bittide/Instances/Pnr/ProcessingElement.hs b/bittide-instances/src/Bittide/Instances/Pnr/ProcessingElement.hs index 864544585..fedb011dd 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/ProcessingElement.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/ProcessingElement.hs @@ -9,7 +9,7 @@ module Bittide.Instances.Pnr.ProcessingElement where import Clash.Prelude import Clash.Annotations.TH -import Clash.Explicit.Prelude(orReset, noReset) +import Clash.Explicit.Prelude (noReset, orReset) import Clash.Xilinx.ClockGen import Language.Haskell.TH import Protocols @@ -24,23 +24,29 @@ import Bittide.SharedTypes import Bittide.Wishbone import Project.FilePath --- | A simple instance containing just VexRisc and UART as peripheral. --- Runs the `hello` binary from `firmware-binaries`. +{- | A simple instance containing just VexRisc and UART as peripheral. +Runs the `hello` binary from `firmware-binaries`. +-} vexRiscUartHello :: "SYSCLK_300" ::: DiffClock Ext300 -> "CPU_RESET" ::: Reset Basic200 -> - ( "" ::: ( "USB_UART_TX" ::: Signal Basic200 Bit - , "JTAG" ::: Signal Basic200 JtagIn + ( "" + ::: ( "USB_UART_TX" ::: Signal Basic200 Bit + , "JTAG" ::: Signal Basic200 JtagIn ) , Signal Basic200 () ) -> - ( "" ::: ( "" ::: Signal Basic200 () - , "JTAG" ::: Signal Basic200 JtagOut ) + ( "" + ::: ( "" ::: Signal Basic200 () + , "JTAG" ::: Signal Basic200 JtagOut + ) , "USB_UART_RX" ::: Signal Basic200 Bit ) vexRiscUartHello diffClk rst_in = - toSignals $ withClockResetEnable clk200 rst200 enableGen $ - circuit $ \(uartRx, jtag) -> do + toSignals + $ withClockResetEnable clk200 rst200 enableGen + $ circuit + $ \(uartRx, jtag) -> do [uartBus, timeBus] <- processingElement @Basic200 peConfig -< jtag (uartTx, _uartStatus) <- uartWb d16 d16 (SNat @921600) -< (uartBus, uartRx) timeWb -< timeBus @@ -48,14 +54,16 @@ vexRiscUartHello diffClk rst_in = where (clk200, rst200_) = clockWizardDifferential diffClk noReset rst200 = rst200_ `orReset` rst_in - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Debug - elfPath = elfDir "hello" - iSize = 64 * 1024 -- 64 KB - dSize = 64 * 1024 -- 64 KB - memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing) + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Debug + elfPath = elfDir "hello" + iSize = 64 * 1024 -- 64 KB + dSize = 64 * 1024 -- 64 KB + memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing + ) -- ╭────────┬───────┬───────┬────────────────────╮ -- │ bin │ hex │ bus │ description │ @@ -70,10 +78,10 @@ vexRiscUartHello diffClk rst_in = -- │ 0b111. │ 0xE │ │ │ -- ╰────────┴───────┴───────┴────────────────────╯ - peConfig = - PeConfig (0b00 :> 0b01 :> 0b10 :> 0b11 :> Nil) - (Reloadable $ Blob iMem) - (Reloadable $ Blob dMem) + PeConfig + (0b00 :> 0b01 :> 0b10 :> 0b11 :> Nil) + (Reloadable $ Blob iMem) + (Reloadable $ Blob dMem) makeTopEntity 'vexRiscUartHello diff --git a/bittide-instances/src/Bittide/Instances/Pnr/ScatterGather.hs b/bittide-instances/src/Bittide/Instances/Pnr/ScatterGather.hs index 1e426627d..f9dffbdad 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/ScatterGather.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/ScatterGather.hs @@ -23,34 +23,42 @@ scatterCal1K :: ScatterConfig WishboneWidth WishboneAddrWidth scatterCal1K = ScatterConfig cal where cal :: CalendarConfig WishboneWidth WishboneAddrWidth (Index 1024) - cal = CalendarConfig (SNat @1024) - (ValidEntry{veEntry=0, veRepeat = 0 :: Unsigned 8} :> Nil) - (ValidEntry{veEntry=0, veRepeat = 0 :: Unsigned 8} :> Nil) + cal = + CalendarConfig + (SNat @1024) + (ValidEntry{veEntry = 0, veRepeat = 0 :: Unsigned 8} :> Nil) + (ValidEntry{veEntry = 0, veRepeat = 0 :: Unsigned 8} :> Nil) gatherCal1K :: GatherConfig WishboneWidth WishboneAddrWidth gatherCal1K = GatherConfig cal where cal :: CalendarConfig WishboneWidth WishboneAddrWidth (Index 1024) - cal = CalendarConfig (SNat @1024) - (ValidEntry{veEntry=0, veRepeat = 0 :: Unsigned 8} :> Nil) - (ValidEntry{veEntry=0, veRepeat = 0 :: Unsigned 8} :> Nil) + cal = + CalendarConfig + (SNat @1024) + (ValidEntry{veEntry = 0, veRepeat = 0 :: Unsigned 8} :> Nil) + (ValidEntry{veEntry = 0, veRepeat = 0 :: Unsigned 8} :> Nil) -{-# ANN scatterUnit1K - (Synthesize - { t_name = "scatterUnit1K" - , t_inputs = - [ PortName "clk" - , PortName "rst" - , PortName "wbInCal" - , PortName "linkIn" - , PortName "wbInSu" - ] - , t_output = PortProduct "" - [ PortName "wbOutSu" - , PortName "wbOutCal" - ] - } - )#-} +{-# ANN + scatterUnit1K + ( Synthesize + { t_name = "scatterUnit1K" + , t_inputs = + [ PortName "clk" + , PortName "rst" + , PortName "wbInCal" + , PortName "linkIn" + , PortName "wbInSu" + ] + , t_output = + PortProduct + "" + [ PortName "wbOutSu" + , PortName "wbOutCal" + ] + } + ) + #-} scatterUnit1K :: Clock Basic200 -> Reset Basic200 -> @@ -58,7 +66,8 @@ scatterUnit1K :: Signal Basic200 (DataLink 64) -> Signal Basic200 (WishboneM2S WishboneAddrWidth WishboneWidth (Bytes WishboneWidth)) -> ( Signal Basic200 (WishboneS2M (Bytes WishboneWidth)) - , Signal Basic200 (WishboneS2M (Bytes WishboneWidth))) + , Signal Basic200 (WishboneS2M (Bytes WishboneWidth)) + ) scatterUnit1K clk rst = withClockResetEnable clk rst enableGen $ scatterUnitWb scatterCal1K {-# NOINLINE scatterUnit1K #-} @@ -67,24 +76,28 @@ scatterUnit1KReducedPins :: scatterUnit1KReducedPins clk rst = withClockResetEnable clk rst enableGen $ reducePins scatterUnit1K' where - scatterUnit1K' (unbundle -> (a,b,c)) = bundle $ scatterUnit1K clk rst a b c + scatterUnit1K' (unbundle -> (a, b, c)) = bundle $ scatterUnit1K clk rst a b c -{-# ANN gatherUnit1K - (Synthesize - { t_name = "gatherUnit1K" - , t_inputs = - [ PortName "clk" - , PortName "rst" - , PortName "wbInCal" - , PortName "wbInGu" - ] - , t_output = PortProduct "" - [ PortName "linkOut" - , PortName "wbOutGu" - , PortName "wbOutCal" - ] - } - )#-} +{-# ANN + gatherUnit1K + ( Synthesize + { t_name = "gatherUnit1K" + , t_inputs = + [ PortName "clk" + , PortName "rst" + , PortName "wbInCal" + , PortName "wbInGu" + ] + , t_output = + PortProduct + "" + [ PortName "linkOut" + , PortName "wbOutGu" + , PortName "wbOutCal" + ] + } + ) + #-} gatherUnit1K :: Clock Basic200 -> Reset Basic200 -> @@ -92,7 +105,8 @@ gatherUnit1K :: Signal Basic200 (WishboneM2S WishboneAddrWidth WishboneWidth (Bytes WishboneWidth)) -> ( Signal Basic200 (DataLink 64) , Signal Basic200 (WishboneS2M (Bytes WishboneWidth)) - , Signal Basic200 (WishboneS2M (Bytes WishboneWidth))) + , Signal Basic200 (WishboneS2M (Bytes WishboneWidth)) + ) gatherUnit1K clk rst = withClockResetEnable clk rst enableGen $ gatherUnitWb gatherCal1K {-# NOINLINE gatherUnit1K #-} @@ -101,4 +115,4 @@ gatherUnit1KReducedPins :: gatherUnit1KReducedPins clk rst = withClockResetEnable clk rst enableGen $ reducePins gatherUnit1K' where - gatherUnit1K' (unbundle -> (a,b)) = bundle $ gatherUnit1K clk rst a b + gatherUnit1K' (unbundle -> (a, b)) = bundle $ gatherUnit1K clk rst a b diff --git a/bittide-instances/src/Bittide/Instances/Pnr/Si539xSpi.hs b/bittide-instances/src/Bittide/Instances/Pnr/Si539xSpi.hs index ff1aa9a41..762874860 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/Si539xSpi.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/Si539xSpi.hs @@ -26,77 +26,105 @@ si5391Spi :: "reset" ::: Reset Basic125 -> "extOp" ::: Signal Basic125 (Maybe RegisterOperation) -> "MISO" ::: Signal Basic125 Bit -> - "" ::: - ( "readByte" ::: Signal Basic125 (Maybe Byte) - , "BUSY" ::: Signal Basic125 Busy - , "STATE" ::: Signal Basic125 (ConfigState Basic125 TestConfig6_200_on_0a_TotalRegs) - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool) - ) -si5391Spi clk rst extOp miso = withClockResetEnable clk rst enableGen $ - si539xSpi testConfig6_200_on_0a_1ppb (SNat @50000) extOp miso + "" + ::: ( "readByte" ::: Signal Basic125 (Maybe Byte) + , "BUSY" ::: Signal Basic125 Busy + , "STATE" ::: Signal Basic125 (ConfigState Basic125 TestConfig6_200_on_0a_TotalRegs) + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) + ) +si5391Spi clk rst extOp miso = + withClockResetEnable clk rst enableGen + $ si539xSpi testConfig6_200_on_0a_1ppb (SNat @50000) extOp miso makeTopEntity 'si5391Spi --- | An instance that combines the following components: --- --- * 'Si539xSpi' core to configure the @Si5395J@ chip over SPI and enable --- further SPI communication --- --- * a `resettableXilinxElasticBuffer` to obtain the datacounts for `callisto`. --- --- * `callistoClockControl` to run the control algorithm that adjusts the --- clock frequency. --- --- * A `spiFrequencyController` to convert `callisto`s `SpeedChange`s into --- `RegisterOperation`s for the `Si539xSpi`. --- --- * A `stabilityChecker` to indicate when the clocks are considered to be --- synchronized. +{- | An instance that combines the following components: + + * 'Si539xSpi' core to configure the @Si5395J@ chip over SPI and enable + further SPI communication + + * a `resettableXilinxElasticBuffer` to obtain the datacounts for `callisto`. + + * `callistoClockControl` to run the control algorithm that adjusts the + clock frequency. + + * A `spiFrequencyController` to convert `callisto`s `SpeedChange`s into + `RegisterOperation`s for the `Si539xSpi`. + + * A `stabilityChecker` to indicate when the clocks are considered to be + synchronized. +-} callistoSpi :: - "CLK_125MHZ" ::: Clock Basic125 -> - "clkRecovered" ::: Clock Internal -> - "clkControlled" ::: Clock External -> - "reset125" ::: Reset Basic125 -> - "locked" ::: Signal External Bool -> - "MISO" ::: Signal Basic125 Bit -> - "" ::: - ( "BUSY" ::: Signal Basic125 Busy - , "DONE" ::: Signal Basic125 Bool - , "EBPASS" ::: Signal External Bool - , "EBSTABLE" ::: Signal External Bool - , "" ::: - ( "SCLK" ::: Signal Basic125 Bool - , "MOSI" ::: Signal Basic125 Bit - , "CSB" ::: Signal Basic125 Bool) - ) + "CLK_125MHZ" ::: Clock Basic125 -> + "clkRecovered" ::: Clock Internal -> + "clkControlled" ::: Clock External -> + "reset125" ::: Reset Basic125 -> + "locked" ::: Signal External Bool -> + "MISO" ::: Signal Basic125 Bit -> + "" + ::: ( "BUSY" ::: Signal Basic125 Busy + , "DONE" ::: Signal Basic125 Bool + , "EBPASS" ::: Signal External Bool + , "EBSTABLE" ::: Signal External Bool + , "" + ::: ( "SCLK" ::: Signal Basic125 Bool + , "MOSI" ::: Signal Basic125 Bit + , "CSB" ::: Signal Basic125 Bool + ) + ) callistoSpi clk125 clkRecovered clkControlled rst125 locked miso = (spiBusy, configState .==. pure Finished, ebMode .==. pure Pass, isStable, spiOut) where -- Spi core, the maximum clock period of 75 Nanoseconds leads to a nice 5 to 1 clock -- divider at 125MHz, resulting in a SPI clock frequencu of 12.5MHz. The -- SPI core _should_ be able to support a SPI clock frequency of 20MHz. - (_, spiBusy, configState, spiOut) = withClockResetEnable clk125 configReset enableGen - si539xSpi testConfig6_200_5_20 (SNat @(Nanoseconds 75)) freqOp miso + (_, spiBusy, configState, spiOut) = + withClockResetEnable + clk125 + configReset + enableGen + si539xSpi + testConfig6_200_5_20 + (SNat @(Nanoseconds 75)) + freqOp + miso -- Reset the spi core when configuration fails to try again. - configReset = withClockResetEnable clk125 rst125 enableGen $ - forceReset . holdTrue d3 $ flip fmap configState \case + configReset = withClockResetEnable clk125 rst125 enableGen + $ forceReset + . holdTrue d3 + $ flip fmap configState \case Error _ -> True - _ -> False + _ -> False -- Convert the SpeedChange produced by Callisto into a RegisterOperation for Si539x - freqOp = spiFrequencyController d128 d127 - clkControlled rstControlled enableGen - clk125 rst125 enableGen speedChange200 spiBusy + freqOp = + spiFrequencyController + d128 + d127 + clkControlled + rstControlled + enableGen + clk125 + rst125 + enableGen + speedChange200 + spiBusy -- Produce a SpeedChange based on the elastic buffer's datacount. speedChange200 = - (fromMaybe NoChange . maybeSpeedChange) <$> - callistoClockControl @1 @12 clkControlled clockControlReset enableGen - clockConfig (pure maxBound) (bufferOccupancy :> Nil) + (fromMaybe NoChange . maybeSpeedChange) + <$> callistoClockControl @1 @12 + clkControlled + clockControlReset + enableGen + clockConfig + (pure maxBound) + (bufferOccupancy :> Nil) -- ALl circuitry in the controlled domain should be in reset while the the PLL is not locked. rstControlled = unsafeFromActiveLow locked @@ -106,16 +134,21 @@ callistoSpi clk125 clkRecovered clkControlled rst125 locked miso = -- The elastic buffer. (bufferOccupancy, _, _, ebMode, _) = - withReset rstControlled $ - resettableXilinxElasticBuffer clkControlled clkRecovered (unsafeFromActiveLow $ pure True) (pure False) + withReset rstControlled + $ resettableXilinxElasticBuffer + clkControlled + clkRecovered + (unsafeFromActiveLow $ pure True) + (pure False) -- Determine if the controlled clock is synchronized "enough" with the static clock. isStable = - withClockResetEnable clkControlled (unsafeFromActiveLow $ pure True) enableGen $ - settled <$> stabilityChecker d5 (SNat @1_000_000) bufferOccupancy + withClockResetEnable clkControlled (unsafeFromActiveLow $ pure True) enableGen + $ settled + <$> stabilityChecker d5 (SNat @1_000_000) bufferOccupancy -- Configuration for Callisto clockConfig :: ClockControlConfig External 12 8 1500000 - clockConfig = $(lift ((defClockConfig @External){cccPessimisticSettleCycles = 20000} )) + clockConfig = $(lift ((defClockConfig @External){cccPessimisticSettleCycles = 20000})) makeTopEntity 'callistoSpi diff --git a/bittide-instances/src/Bittide/Instances/Pnr/StabilityChecker.hs b/bittide-instances/src/Bittide/Instances/Pnr/StabilityChecker.hs index 5b58b8886..c362d7bb3 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/StabilityChecker.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/StabilityChecker.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE NumericUnderscores #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE NumericUnderscores #-} module Bittide.Instances.Pnr.StabilityChecker where import Clash.Prelude +import Bittide.ClockControl (RelDataCount) import Bittide.ClockControl.StabilityChecker import Bittide.Instances.Domains (Basic200) -import Bittide.ClockControl (RelDataCount) stabilityChecker_3_1M :: Clock Basic200 -> @@ -18,5 +18,5 @@ stabilityChecker_3_1M :: Signal Basic200 (RelDataCount 16) -> Signal Basic200 StabilityIndication stabilityChecker_3_1M clk rst = - withClockResetEnable clk rst enableGen $ - stabilityChecker d3 (SNat @1_000_000) + withClockResetEnable clk rst enableGen + $ stabilityChecker d3 (SNat @1_000_000) diff --git a/bittide-instances/src/Bittide/Instances/Pnr/Synchronizer.hs b/bittide-instances/src/Bittide/Instances/Pnr/Synchronizer.hs index 30ec941f2..b82159ef8 100644 --- a/bittide-instances/src/Bittide/Instances/Pnr/Synchronizer.hs +++ b/bittide-instances/src/Bittide/Instances/Pnr/Synchronizer.hs @@ -8,13 +8,12 @@ import Clash.Explicit.Prelude import Bittide.Instances.Domains -import qualified Clash.Cores.Extra as Cores import Clash.Annotations.TH (makeTopEntity) - +import qualified Clash.Cores.Extra as Cores safeDffSynchronizer :: - "clk1" ::: Clock Basic200 -> - "clk2" ::: Clock Basic199 -> + "clk1" ::: Clock Basic200 -> + "clk2" ::: Clock Basic199 -> "source" ::: Signal Basic200 Bit -> "target" ::: Signal Basic199 Bit safeDffSynchronizer clk1 clk2 = diff --git a/bittide-instances/src/Paths/Bittide/Instances.hs b/bittide-instances/src/Paths/Bittide/Instances.hs index 42f0afa4a..8e0fa65b4 100644 --- a/bittide-instances/src/Paths/Bittide/Instances.hs +++ b/bittide-instances/src/Paths/Bittide/Instances.hs @@ -2,8 +2,8 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Paths.Bittide.Instances - ( module Paths_bittide_instances - ) where +module Paths.Bittide.Instances ( + module Paths_bittide_instances, +) where -import Paths_bittide_instances \ No newline at end of file +import Paths_bittide_instances diff --git a/bittide-instances/src/Project/FilePath.hs b/bittide-instances/src/Project/FilePath.hs index 7ca40a9cb..00d5736bc 100644 --- a/bittide-instances/src/Project/FilePath.hs +++ b/bittide-instances/src/Project/FilePath.hs @@ -13,61 +13,65 @@ import System.FilePath >>> import Clash.Prelude -} --- | Relative path to the build directory. --- --- Example: --- --- >>> buildDir --- "_build" +{- | Relative path to the build directory. + +Example: + +>>> buildDir +"_build" +-} buildDir :: FilePath buildDir = "_build" --- | Relative path to the build directory. --- --- Example: --- --- >>> cargoDir --- "_build/cargo" +{- | Relative path to the build directory. + +Example: + +>>> cargoDir +"_build/cargo" +-} cargoDir :: FilePath cargoDir = buildDir "cargo" data CargoBuildType = Release | Debug deriving (Eq) --- | Relative path to the firmware binaries directory. --- --- Example: --- --- >>> firmwareBinariesDir "riscv32imc-unknown-none-elf" Release --- "_build/cargo/firmware-binaries/riscv32imc-unknown-none-elf/release" + +{- | Relative path to the firmware binaries directory. + +Example: + +>>> firmwareBinariesDir "riscv32imc-unknown-none-elf" Release +"_build/cargo/firmware-binaries/riscv32imc-unknown-none-elf/release" +-} firmwareBinariesDir :: String -> CargoBuildType -> FilePath firmwareBinariesDir rustTargetArchitecture buildType = cargoDir - "firmware-binaries" - rustBinSubDir rustTargetArchitecture buildType + "firmware-binaries" + rustBinSubDir rustTargetArchitecture buildType --- | Firmware binaries directory relative to cargo's target directory. --- --- Example: --- --- >>> rustBinSubDir "riscv32imc-unknown-none-elf" Release --- "riscv32imc-unknown-none-elf/release" +{- | Firmware binaries directory relative to cargo's target directory. + +Example: + +>>> rustBinSubDir "riscv32imc-unknown-none-elf" Release +"riscv32imc-unknown-none-elf/release" +-} rustBinSubDir :: String -> CargoBuildType -> FilePath rustBinSubDir rustTargetArchitecture buildType = - rustTargetArchitecture - case buildType of - Release -> "release" - Debug -> "debug" + rustTargetArchitecture + case buildType of + Release -> "release" + Debug -> "debug" -- | Recursive function that returns a parent directory containing a certain filename. findParentContaining :: String -> IO FilePath findParentContaining filename = goUp =<< getCurrentDirectory - where - goUp :: FilePath -> IO FilePath - goUp path - | isDrive path = throwIO $ userError $ "Could not find " <> filename - | otherwise = do - exists <- doesFileExist (path filename) - if exists then - return path - else - goUp (takeDirectory path) + where + goUp :: FilePath -> IO FilePath + goUp path + | isDrive path = throwIO $ userError $ "Could not find " <> filename + | otherwise = do + exists <- doesFileExist (path filename) + if exists + then return path + else goUp (takeDirectory path) diff --git a/bittide-instances/tests/Tests/OverflowResistantDiff.hs b/bittide-instances/tests/Tests/OverflowResistantDiff.hs index 3e5758fae..cf79abf41 100644 --- a/bittide-instances/tests/Tests/OverflowResistantDiff.hs +++ b/bittide-instances/tests/Tests/OverflowResistantDiff.hs @@ -1,8 +1,8 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} + module Tests.OverflowResistantDiff where import Clash.Explicit.Prelude @@ -22,12 +22,18 @@ import qualified GHC.TypeNats as TN import Bittide.Instances.Hitl.IlaPlot tests :: TestTree -tests = testGroup "OverflowResistantDiff" - [ testPropertyNamed "test with step-wise incrementing counter" - "testStepwise" $ ordTest True - , testPropertyNamed "test with randomly incrementing counter" - "testStepwise" $ ordTest False - ] +tests = + testGroup + "OverflowResistantDiff" + [ testPropertyNamed + "test with step-wise incrementing counter" + "testStepwise" + $ ordTest True + , testPropertyNamed + "test with randomly incrementing counter" + "testStepwise" + $ ordTest False + ] ordTest :: Bool -> Property ordTest stepwise = property $ do @@ -35,81 +41,94 @@ ordTest stepwise = property $ do dM <- forAll $ Gen.enum 0 (2 P.^ maxBitSize - 1) case (TN.someNatVal dN, TN.someNatVal dM) of ( SomeNat (snatProxy -> (SNat :: SNat n)) - , SomeNat (snatProxy -> (SNat :: SNat m))) -> - do - inputCounterValues <- fmap (0 :) $ - if stepwise - then return - $ flip List.unfoldr (0 :: Int, 0 :: Unsigned (n + 1)) - $ \(n, o) -> if n == depth - then Nothing - else Just (o, (n + 1, satSucc SatWrap o)) - else forAll - $ Gen.list (Range.singleton depth) - $ genUnsigned Range.linearBounded - - newRefPositions <- forAll - $ Gen.list (Range.linear 10 100) - $ Gen.integral - $ Range.linear 0 (depth - 1) - - let - inputTriggerValues :: [Bool] - inputTriggerValues = (False :) - $ flip List.unfoldr (0, List.nub $ List.sort $ newRefPositions) - $ \(n, xs) -> + , SomeNat (snatProxy -> (SNat :: SNat m)) + ) -> + do + inputCounterValues <- + fmap (0 :) + $ if stepwise + then return + $ flip List.unfoldr (0 :: Int, 0 :: Unsigned (n + 1)) + $ \(n, o) -> + if n == depth + then Nothing + else Just (o, (n + 1, satSucc SatWrap o)) + else + forAll + $ Gen.list (Range.singleton depth) + $ genUnsigned Range.linearBounded + + newRefPositions <- + forAll + $ Gen.list (Range.linear 10 100) + $ Gen.integral + $ Range.linear 0 (depth - 1) + + let + inputTriggerValues :: [Bool] + inputTriggerValues = (False :) + $ flip List.unfoldr (0, List.nub $ List.sort $ newRefPositions) + $ \(n, xs) -> if n == depth - then Nothing - else Just $ case xs of - [] -> (False, (n + 1, [])) - x:xr -> (x == n, ((n + 1), if x == n then xr else xs)) - - -- the generated input lists should be of equal length - List.length inputCounterValues === List.length inputTriggerValues - - let - outputValues :: [DiffResult Integer] - outputValues = fmap toInteger <$> - sampleWithResetN @System @(DiffResult (Index (m + 1))) d1 depth - (\clk rst _ -> overflowResistantDiff clk rst - (fromList inputTriggerValues) - (fromList inputCounterValues) + then Nothing + else Just $ case xs of + [] -> (False, (n + 1, [])) + x : xr -> (x == n, ((n + 1), if x == n then xr else xs)) + + -- the generated input lists should be of equal length + List.length inputCounterValues === List.length inputTriggerValues + + let + outputValues :: [DiffResult Integer] + outputValues = + fmap toInteger + <$> sampleWithResetN @System @(DiffResult (Index (m + 1))) + d1 + depth + ( \clk rst _ -> + overflowResistantDiff + clk + rst + (fromList inputTriggerValues) + (fromList inputCounterValues) + ) + + expectedOutputs = + List.tail + $ List.reverse + $ snd + $ List.foldl golden (Nothing, []) + $ List.zip inputCounterValues inputTriggerValues + + -- don't use fixed size numbers for the golden reference, so + -- there are basically no overflows and we just can compute + -- distance directly, where we discard the if it exceeds the + -- capacity the output type + golden :: + ( Maybe (Integer, Unsigned (n + 1)) + , [DiffResult Integer] + ) -> + (Unsigned (n + 1), Bool) -> + ( Maybe (Integer, Unsigned (n + 1)) + , [DiffResult Integer] ) - expectedOutputs = List.tail - $ List.reverse $ snd $ List.foldl golden (Nothing, []) - $ List.zip inputCounterValues inputTriggerValues - - -- don't use fixed size numbers for the golden reference, so - -- there are basically no overflows and we just can compute - -- distance directly, where we discard the if it exceeds the - -- capacity the output type - golden :: - ( Maybe (Integer, Unsigned (n + 1)) - , [DiffResult Integer] - ) -> (Unsigned (n + 1), Bool) -> - ( Maybe (Integer, Unsigned (n + 1)) - , [DiffResult Integer] - ) - - golden (_, xs) (c, True) - = (Just (0, c), Difference 0 : xs) - - golden (Nothing, xs) _ - = (Nothing, NoReference : xs) - - golden (Just (x, o), xs) (c, _) = - let y = x + toInteger (c - o) - out = if y > toInteger (maxBound :: Index (m + 1)) + golden (_, xs) (c, True) = + (Just (0, c), Difference 0 : xs) + golden (Nothing, xs) _ = + (Nothing, NoReference : xs) + golden (Just (x, o), xs) (c, _) = + let y = x + toInteger (c - o) + out = + if y > toInteger (maxBound :: Index (m + 1)) then TooLarge else Difference y - in (Just (y, c), out : xs) - - -- the generated output lists should be of equal length - List.length outputValues === List.length expectedOutputs + in (Just (y, c), out : xs) - outputValues === expectedOutputs + -- the generated output lists should be of equal length + List.length outputValues === List.length expectedOutputs - where - maxBitSize = 8 - depth = 1000 :: Int + outputValues === expectedOutputs + where + maxBitSize = 8 + depth = 1000 :: Int diff --git a/bittide-instances/tests/Wishbone/Axi.hs b/bittide-instances/tests/Wishbone/Axi.hs index 9e1fcc209..dfe437079 100644 --- a/bittide-instances/tests/Wishbone/Axi.hs +++ b/bittide-instances/tests/Wishbone/Axi.hs @@ -3,8 +3,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} -{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} +{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} module Wishbone.Axi where @@ -17,10 +17,10 @@ import Bittide.ProcessingElement import Bittide.ProcessingElement.Util import Bittide.SharedTypes import Bittide.Wishbone -import Clash.Cores.UART(uart, ValidBaud) -import Clash.Cores.UART.Extra(MaxBaudRate) +import Clash.Cores.UART (ValidBaud, uart) +import Clash.Cores.UART.Extra (MaxBaudRate) import Clash.Explicit.Testbench -import Clash.Prelude(withClockResetEnable) +import Clash.Prelude (withClockResetEnable) import Clash.Xilinx.ClockGen import Control.Monad (forM_) import Data.Char @@ -41,9 +41,9 @@ import VexRiscv import qualified Protocols.DfConv as DfConv - --- | Run the axi module self test with processingElement and inspect it's uart output. --- The test returns names of tests and a boolean indicating if the test passed. +{- | Run the axi module self test with processingElement and inspect it's uart output. +The test returns names of tests and a boolean indicating if the test passed. +-} case_axi_stream_rust_self_test :: Assertion case_axi_stream_rust_self_test = -- Run the test with HUnit @@ -58,15 +58,15 @@ case_axi_stream_rust_self_test = clk = clockGen rst = resetGen ena = enableGen - simResult = fmap (chr . fromIntegral) $ catMaybes $ sampleN 500_000 uartStream + simResult = fmap (chr . fromIntegral) $ catMaybes $ sampleN 500_000 uartStream (uartStream, _, _) = withClockResetEnable (clockGen @Basic50) rst ena $ uart baud uartTx (pure Nothing) (_, uartTx) = dut baud (clockToDiffClock clk) rst (pure 0, pure ()) - --- | A simple instance containing just VexRisc and UART as peripheral. --- Runs the `hello` binary from `firmware-binaries`. +{- | A simple instance containing just VexRisc and UART as peripheral. +Runs the `hello` binary from `firmware-binaries`. +-} dut :: - forall dom baud . + forall dom baud. (KnownDomain dom, ValidBaud dom baud) => SNat baud -> "SYSCLK_300" ::: DiffClock Ext300 -> @@ -74,46 +74,59 @@ dut :: ("USB_UART_TX" ::: Signal dom Bit, Signal dom ()) -> (Signal dom (), "USB_UART_RX" ::: Signal dom Bit) dut baud diffClk rst_in = - toSignals $ withClockResetEnable clk200 rst200 enableGen $ - circuit $ \uartTx -> do + toSignals + $ withClockResetEnable clk200 rst200 enableGen + $ circuit + $ \uartTx -> do [uartBus, axiTxBus, wbNull, axiRxBus] <- processingElement @dom peConfig <| jtagIdle -< () wbAlwaysAck -< wbNull (uartRx, _uartStatus) <- uartWb d128 d2 baud -< (uartBus, uartTx) _interrupts <- wbAxisRxBufferCircuit (SNat @128) -< (axiRxBus, axiStream) - axiStream <- axiUserMapC (const False) <| DfConv.fifo axiProxy axiProxy (SNat @1024) <| - axiPacking <| wbToAxiTx -< axiTxBus + axiStream <- + axiUserMapC (const False) + <| DfConv.fifo axiProxy axiProxy (SNat @1024) + <| axiPacking + <| wbToAxiTx + -< axiTxBus idC -< uartRx where axiProxy = Proxy @(Axi4Stream dom ('Axi4StreamConfig 4 0 0) ()) (clk200 :: Clock dom, pllLock :: Reset dom) = clockWizardDifferential diffClk noReset rst200 = resetSynchronizer clk200 (unsafeOrReset rst_in pllLock) - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release - elfPath = elfDir "axi_stream_self_test" - memBlobsFromElf BigEndian (Nothing, Nothing) elfPath Nothing) + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release + elfPath = elfDir "axi_stream_self_test" + memBlobsFromElf BigEndian (Nothing, Nothing) elfPath Nothing + ) jtagIdle = Circuit $ const ((), pure $ JtagIn low low low) peConfig = PeConfig - (0b000 :> 0b001 :> 0b010 :> 0b011:> 0b100 :> 0b101 :> Nil) - (Reloadable $ Blob iMem) - (Reloadable $ Blob dMem) - + (0b000 :> 0b001 :> 0b010 :> 0b011 :> 0b100 :> 0b101 :> Nil) + (Reloadable $ Blob iMem) + (Reloadable $ Blob dMem) data TestResult = TestResult String (Maybe String) deriving (Show, Eq) -wbAlwaysAck :: NFDataX a => Circuit - (Wishbone dom 'Standard addrW a) - () +wbAlwaysAck :: + (NFDataX a) => + Circuit + (Wishbone dom 'Standard addrW a) + () wbAlwaysAck = Circuit (const (pure $ emptyWishboneS2M{acknowledge = True}, ())) testResultParser :: Parser TestResult testResultParser = do testName <- manyTill anyChar (try (string ": ")) - result <- choice [string "None" >> return Nothing, Just <$> (string "Some(" *> manyTill anyChar (char ')'))] + result <- + choice + [ string "None" >> return Nothing + , Just <$> (string "Some(" *> manyTill anyChar (char ')')) + ] _ <- endOfLine return $ TestResult testName result @@ -121,11 +134,12 @@ testResultsParser :: Parser [TestResult] testResultsParser = do _ <- string "Start axi self test" >> endOfLine manyTill testResultParser done - where - done = try (string "Done") >> endOfLine >> return () + where + done = try (string "Done") >> endOfLine >> return () --- | Parse test results from the simulation output. See 'case_parseTestResults' --- for example inputs. +{- | Parse test results from the simulation output. See 'case_parseTestResults' +for example inputs. +-} parseTestResults :: String -> Either ParseError [TestResult] parseTestResults = parse testResultsParser "" @@ -133,14 +147,14 @@ case_parseTestResults :: Assertion case_parseTestResults = do Right [] @=? parseTestResults "Start axi self test\nDone\n" - Right [TestResult "a" Nothing] @=? - parseTestResults "Start axi self test\na: None\nDone\n" + Right [TestResult "a" Nothing] + @=? parseTestResults "Start axi self test\na: None\nDone\n" - Right [TestResult "a" Nothing, TestResult "b" Nothing] @=? - parseTestResults "Start axi self test\na: None\nb: None\nDone\n" + Right [TestResult "a" Nothing, TestResult "b" Nothing] + @=? parseTestResults "Start axi self test\na: None\nb: None\nDone\n" - Right [TestResult "a" (Just "1"),TestResult "b" Nothing] @=? - parseTestResults "Start axi self test\na: Some(1)\nb: None\nDone\n" + Right [TestResult "a" (Just "1"), TestResult "b" Nothing] + @=? parseTestResults "Start axi self test\na: Some(1)\nb: None\nDone\n" tests :: TestTree tests = $(testGroupGenerator) diff --git a/bittide-instances/tests/Wishbone/DnaPortE2.hs b/bittide-instances/tests/Wishbone/DnaPortE2.hs index 0e3752933..0c513d2a5 100644 --- a/bittide-instances/tests/Wishbone/DnaPortE2.hs +++ b/bittide-instances/tests/Wishbone/DnaPortE2.hs @@ -8,9 +8,9 @@ module Wishbone.DnaPortE2 where import Clash.Explicit.Prelude -import Clash.Prelude(withClockResetEnable) +import Clash.Prelude (withClockResetEnable) -import Clash.Cores.UART(uart, ValidBaud) +import Clash.Cores.UART (ValidBaud, uart) import Clash.Cores.Xilinx.Unisim.DnaPortE2 import Clash.Explicit.Testbench import Clash.Xilinx.ClockGen @@ -32,7 +32,7 @@ import Bittide.ProcessingElement import Bittide.ProcessingElement.Util import Bittide.SharedTypes import Bittide.Wishbone -import Clash.Cores.UART.Extra(MaxBaudRate) +import Clash.Cores.UART.Extra (MaxBaudRate) import qualified Prelude as P @@ -40,7 +40,11 @@ import qualified Prelude as P case_dna_port_self_test :: Assertion case_dna_port_self_test = assertBool msg (receivedDna == simDna2) where - msg = "Received dna " <> showHex receivedDna "" <> " not equal to expected dna " <> showHex simDna2 "" + msg = + "Received dna " + <> showHex receivedDna "" + <> " not equal to expected dna " + <> showHex simDna2 "" receivedDna = parseResult simResult baud = SNat @(MaxBaudRate Basic50) clk = clockGen @@ -50,10 +54,11 @@ case_dna_port_self_test = assertBool msg (receivedDna == simDna2) (uartStream, _, _) = withClockResetEnable (clockGen @Basic50) rst ena $ uart baud uartTx (pure Nothing) uartTx = dut baud (clockToDiffClock clk) rst (pure 0) --- | A simple instance containing just VexRisc with UART and the DNA peripheral which --- runs the `dna_port_e2_test` binary from `firmware-binaries`. +{- | A simple instance containing just VexRisc with UART and the DNA peripheral which +runs the `dna_port_e2_test` binary from `firmware-binaries`. +-} dut :: - forall dom baud . + forall dom baud. (KnownDomain dom, ValidBaud dom baud) => SNat baud -> "SYSCLK_300" ::: DiffClock Ext300 -> @@ -65,8 +70,10 @@ dut baud diffClk rst_in usbUartTx = usbUartRx (_, usbUartRx) = go ((usbUartTx, pure $ JtagIn low low low), pure ()) go = - toSignals $ withClockResetEnable clk200 rst200 enableGen $ - circuit $ \(uartRx, jtag) -> do + toSignals + $ withClockResetEnable clk200 rst200 enableGen + $ circuit + $ \(uartRx, jtag) -> do [uartBus, dnaWb] <- processingElement @dom peConfig -< jtag (uartTx, _uartStatus) <- uartWb d256 d16 baud -< (uartBus, uartRx) readDnaPortE2Wb simDna2 -< dnaWb @@ -75,18 +82,21 @@ dut baud diffClk rst_in usbUartTx = usbUartRx (clk200 :: Clock dom, pllLock :: Reset dom) = clockWizardDifferential diffClk noReset rst200 = resetSynchronizer clk200 (unsafeOrReset rst_in pllLock) - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release - elfPath = elfDir "dna_port_e2_test" + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release + elfPath = elfDir "dna_port_e2_test" - memBlobsFromElf BigEndian (Nothing, Nothing) elfPath Nothing) + memBlobsFromElf BigEndian (Nothing, Nothing) elfPath Nothing + ) peConfig = - PeConfig (0b00 :> 0b01 :> 0b10 :> 0b11 :> Nil) - (Reloadable $ Blob iMem) - (Reloadable $ Blob dMem) + PeConfig + (0b00 :> 0b01 :> 0b10 :> 0b11 :> Nil) + (Reloadable $ Blob iMem) + (Reloadable $ Blob dMem) parseResult :: String -> BitVector 96 parseResult = pack . (read :: String -> Unsigned 96) . P.head . lines diff --git a/bittide-instances/tests/Wishbone/Time.hs b/bittide-instances/tests/Wishbone/Time.hs index a39290509..1ea461dda 100644 --- a/bittide-instances/tests/Wishbone/Time.hs +++ b/bittide-instances/tests/Wishbone/Time.hs @@ -13,11 +13,11 @@ import Bittide.ProcessingElement import Bittide.ProcessingElement.Util import Bittide.SharedTypes import Bittide.Wishbone -import Clash.Cores.UART(uart, ValidBaud) -import Clash.Cores.UART.Extra(MaxBaudRate) +import Clash.Cores.UART (ValidBaud, uart) +import Clash.Cores.UART.Extra (MaxBaudRate) import Clash.Explicit.Prelude import Clash.Explicit.Testbench -import Clash.Prelude(withClockResetEnable) +import Clash.Prelude (withClockResetEnable) import Clash.Xilinx.ClockGen import Control.Monad (forM_) import Data.Char @@ -33,9 +33,9 @@ import Text.Parsec import Text.Parsec.String import VexRiscv - --- | Run the timing module self test with processingElement and inspect it's uart output. --- The test returns names of tests and a boolean indicating if the test passed. +{- | Run the timing module self test with processingElement and inspect it's uart output. +The test returns names of tests and a boolean indicating if the test passed. +-} case_time_rust_self_test :: Assertion case_time_rust_self_test = -- Run the test with HUnit @@ -54,10 +54,11 @@ case_time_rust_self_test = (uartStream, _, _) = withClockResetEnable (clockGen @Basic50) rst ena $ uart baud uartTx (pure Nothing) uartTx = dut baud (clockToDiffClock clk) rst (pure 0) --- | A simple instance containing just VexRisc and UART as peripheral. --- Runs the `hello` binary from `firmware-binaries`. +{- | A simple instance containing just VexRisc and UART as peripheral. +Runs the `hello` binary from `firmware-binaries`. +-} dut :: - forall dom baud . + forall dom baud. (KnownDomain dom, ValidBaud dom baud) => SNat baud -> "SYSCLK_300" ::: DiffClock Ext300 -> @@ -69,8 +70,10 @@ dut baud diffClk rst_in usbUartTx = usbUartRx (_, usbUartRx) = go ((usbUartTx, pure $ JtagIn low low low), pure ()) go = - toSignals $ withClockResetEnable clk200 rst200 enableGen $ - circuit $ \(uartRx, jtag) -> do + toSignals + $ withClockResetEnable clk200 rst200 enableGen + $ circuit + $ \(uartRx, jtag) -> do [uartBus, timeBus] <- processingElement @dom peConfig -< jtag (uartTx, _uartStatus) <- uartWb d256 d16 baud -< (uartBus, uartRx) timeWb -< timeBus @@ -79,23 +82,25 @@ dut baud diffClk rst_in usbUartTx = usbUartRx (clk200 :: Clock dom, pllLock :: Reset dom) = clockWizardDifferential diffClk noReset rst200 = resetSynchronizer clk200 (unsafeOrReset rst_in pllLock) - (iMem, dMem) = $(do - root <- runIO $ findParentContaining "cabal.project" - let - elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release - elfPath = elfDir "time_self_test" + (iMem, dMem) = + $( do + root <- runIO $ findParentContaining "cabal.project" + let + elfDir = root firmwareBinariesDir "riscv32imc-unknown-none-elf" Release + elfPath = elfDir "time_self_test" - iSize = 64 * 1024 -- 64 KB - dSize = 64 * 1024 -- 64 KB - memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing) + iSize = 64 * 1024 -- 64 KB + dSize = 64 * 1024 -- 64 KB + memBlobsFromElf BigEndian (Just iSize, Just dSize) elfPath Nothing + ) peConfig = - PeConfig (0b00 :> 0b01 :> 0b10 :> 0b11 :> Nil) - (Reloadable $ Blob iMem) - (Reloadable $ Blob dMem) - -data TestResult = TestResult String (Maybe String) deriving Show + PeConfig + (0b00 :> 0b01 :> 0b10 :> 0b11 :> Nil) + (Reloadable $ Blob iMem) + (Reloadable $ Blob dMem) +data TestResult = TestResult String (Maybe String) deriving (Show) type Ascii = BitVector 8 asciiToChar :: Ascii -> Char @@ -104,7 +109,11 @@ asciiToChar = chr . fromIntegral testResultParser :: Parser TestResult testResultParser = do testName <- manyTill anyChar (try (string ": ")) - result <- choice [string "None" >> return Nothing, Just <$> (string "Some(" *> manyTill anyChar (char ')'))] + result <- + choice + [ string "None" >> return Nothing + , Just <$> (string "Some(" *> manyTill anyChar (char ')')) + ] _ <- endOfLine return $ TestResult testName result @@ -112,8 +121,8 @@ testResultsParser :: Parser [TestResult] testResultsParser = do _ <- string "Start time self test" >> endOfLine manyTill testResultParser done - where - done = try (string "Done") >> endOfLine >> return () + where + done = try (string "Done") >> endOfLine >> return () parseTestResults :: String -> Either ParseError [TestResult] parseTestResults = parse testResultsParser "" diff --git a/bittide-instances/tests/doctests.hs b/bittide-instances/tests/doctests.hs index 05a3d47cf..2cb8b6ccf 100644 --- a/bittide-instances/tests/doctests.hs +++ b/bittide-instances/tests/doctests.hs @@ -4,11 +4,11 @@ module Main where -import Test.DocTest (mainFromCabal) import System.Environment (getArgs) +import Test.DocTest (mainFromCabal) main :: IO () main = do -- We use Nix to setup tooling, not to provide GHC packages so we need to set --no-nix args <- getArgs - mainFromCabal "bittide-instances" ("--no-nix":args) + mainFromCabal "bittide-instances" ("--no-nix" : args) diff --git a/bittide-instances/tests/unittests.hs b/bittide-instances/tests/unittests.hs index 5f11ea82a..3ea3eedc3 100644 --- a/bittide-instances/tests/unittests.hs +++ b/bittide-instances/tests/unittests.hs @@ -13,14 +13,15 @@ import qualified Wishbone.Axi as Axi import qualified Wishbone.DnaPortE2 as DnaPortE2 import qualified Wishbone.Time as Time - tests :: TestTree -tests = testGroup "Unittests" - [ DnaPortE2.tests - , Ord.tests - , Time.tests - , Axi.tests - ] +tests = + testGroup + "Unittests" + [ DnaPortE2.tests + , Ord.tests + , Time.tests + , Axi.tests + ] main :: IO () main = defaultMain tests diff --git a/bittide-shake/exe/Main.hs b/bittide-shake/exe/Main.hs index 4e1a572f8..02b0de9d5 100644 --- a/bittide-shake/exe/Main.hs +++ b/bittide-shake/exe/Main.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -32,20 +31,21 @@ import Development.Shake.Classes import GHC.Stack (HasCallStack) import System.Console.ANSI (setSGR) import System.Directory hiding (doesFileExist) -import System.Exit (ExitCode(..), exitWith) +import System.Exit (ExitCode (..), exitWith) import System.FilePath import System.FilePath.Glob (glob) -import System.Process (readProcess, callProcess) +import System.Process (callProcess, readProcess) import Test.Tasty.HUnit (Assertion) import qualified Clash.Util.Interpolate as I import qualified Paths.Bittide.Shake as Shake (getDataFileName) import qualified System.Directory as Directory --- | Get all files whose changes will trigger an HDL rebuild. Because we lack a --- reliable way to determine which files should trigger a rebuild, this function --- returns a (very) pessimistic list: all files in the project's directory, --- except files ignored by git and files matching patterns in 'ignorePatterns'. +{- | Get all files whose changes will trigger an HDL rebuild. Because we lack a +reliable way to determine which files should trigger a rebuild, this function +returns a (very) pessimistic list: all files in the project's directory, +except files ignored by git and files matching patterns in 'ignorePatterns'. +-} getWatchFiles :: IO [String] getWatchFiles = do getWatchFilesPy <- @@ -58,21 +58,20 @@ needWatchFiles = do need [watchFilesPath] need =<< liftIO (lines <$> readFile watchFilesPath) --- | File patterns of file we do _not_ want to make trigger a rebuild of HDL --- files. Also see 'getWatchFiles'. +{- | File patterns of file we do _not_ want to make trigger a rebuild of HDL +files. Also see 'getWatchFiles'. +-} ignorePatterns :: [String] ignorePatterns = [ "*.md" , ".github" , ".reuse" , ".vscode" - - -- Used for synthesis, but not for generating Clash output: - , dataFilesDir "**" "*.xdc" + , -- Used for synthesis, but not for generating Clash output: + dataFilesDir "**" "*.xdc" , dataFilesDir "**" "*.tcl" - - -- Used for HITL tests - , "bittide-instances/data/openocd/*" + , -- Used for HITL tests + "bittide-instances/data/openocd/*" , "bittide-instances/data/picocom/*" , "bittide-instances/data/gdb/*" ] @@ -105,14 +104,14 @@ doPostProcessing postProcessMain ilaDir testExitCode = do callProcess "cabal" ["build", postProcessMain] callProcess "cabal" ["run", postProcessMain, ilaDir, show testExitCode] --- | Searches for a file called @cabal.project@ It will look for it in the --- current working directory. If it can't find it there, it will traverse up --- until it finds the file. --- --- The returned path points to the directory containing @cabal.project@. Errors --- if it could not find @cabal.project@ anywhere. --- -findProjectRoot :: HasCallStack => IO FilePath +{- | Searches for a file called @cabal.project@ It will look for it in the +current working directory. If it can't find it there, it will traverse up +until it finds the file. + +The returned path points to the directory containing @cabal.project@. Errors +if it could not find @cabal.project@ anywhere. +-} +findProjectRoot :: (HasCallStack) => IO FilePath findProjectRoot = goUp =<< getCurrentDirectory where goUp :: FilePath -> IO FilePath @@ -127,117 +126,117 @@ findProjectRoot = goUp =<< getCurrentDirectory projectFilename = "cabal.project" data Target = Target - { -- | TemplateHaskell reference to top entity to synthesize - targetName :: TargetName - - -- | Whether target has an associated XDC file in 'data/constraints'. An XDC - -- file implies that a bitstream can be generated. + { targetName :: TargetName + -- ^ TemplateHaskell reference to top entity to synthesize , targetHasXdc :: Bool - - -- | Whether target has one or more VIOs + -- ^ Whether target has an associated XDC file in 'data/constraints'. An XDC + -- file implies that a bitstream can be generated. , targetHasVio :: Bool - - -- | Whether target has a VIO probe that can be used to run hardware-in-the- - -- loop tests. Note that this flag, 'targetHasTest', implies 'targetHasVio'. + -- ^ Whether target has one or more VIOs , targetHasTest :: Bool - - -- | Name of the executable for post processing of ILA CSV data, or Nothing - -- if it has none. + -- ^ Whether target has a VIO probe that can be used to run hardware-in-the- + -- loop tests. Note that this flag, 'targetHasTest', implies 'targetHasVio'. , targetPostProcess :: Maybe String - - -- | Extra constraints to be sourced. Will be sourced _after_ main XDC. + -- ^ Name of the executable for post processing of ILA CSV data, or Nothing + -- if it has none. , targetExtraXdc :: [FilePath] - - -- | A list of patterns that match the external HDL files that are used by the - -- instance. Generates tck that utilizes https://www.tcl.tk/man/tcl8.6/TclCmd/glob.htm + -- ^ Extra constraints to be sourced. Will be sourced _after_ main XDC. , targetExternalHdl :: [TclGlobPattern] + -- ^ A list of patterns that match the external HDL files that are used by the + -- instance. Generates tck that utilizes https://www.tcl.tk/man/tcl8.6/TclCmd/glob.htm } - defTarget :: TargetName -> Target -defTarget name = Target - { targetName = name - , targetHasXdc = False - , targetHasVio = False - , targetHasTest = False - , targetPostProcess = Nothing - , targetExtraXdc = [] - , targetExternalHdl = [] - } +defTarget name = + Target + { targetName = name + , targetHasXdc = False + , targetHasVio = False + , targetHasTest = False + , targetPostProcess = Nothing + , targetExtraXdc = [] + , targetExternalHdl = [] + } testTarget :: TargetName -> Target -testTarget name = Target - { targetName = name - , targetHasXdc = True - , targetHasVio = True - , targetHasTest = True - , targetPostProcess = Nothing - , targetExtraXdc = [] - , targetExternalHdl = [] - } +testTarget name = + Target + { targetName = name + , targetHasXdc = True + , targetHasVio = True + , targetHasTest = True + , targetPostProcess = Nothing + , targetExtraXdc = [] + , targetExternalHdl = [] + } enforceValidTarget :: Target -> Target enforceValidTarget target@Target{..} | targetHasTest && not targetHasVio = - error $ show targetName <> " should have set 'targetHasVio', because " <> - "'targetHasTest' was asserted." + error $ + show targetName + <> " should have set 'targetHasVio', because " + <> "'targetHasTest' was asserted." | otherwise = target - -- | All synthesizable targets targets :: [Target] -targets = map enforceValidTarget - [ defTarget "Bittide.Instances.Pnr.Calendar.switchCalendar1k" - , defTarget "Bittide.Instances.Pnr.Calendar.switchCalendar1kReducedPins" - , defTarget "Bittide.Instances.Pnr.ClockControl.callisto3" - , defTarget "Bittide.Instances.Pnr.Counter.counterReducedPins" - , defTarget "Bittide.Instances.Pnr.ElasticBuffer.elasticBuffer5" - , defTarget "Bittide.Instances.Pnr.ScatterGather.gatherUnit1K" - , defTarget "Bittide.Instances.Pnr.ScatterGather.gatherUnit1KReducedPins" - , defTarget "Bittide.Instances.Pnr.ScatterGather.scatterUnit1K" - , defTarget "Bittide.Instances.Pnr.ScatterGather.scatterUnit1KReducedPins" - , defTarget "Bittide.Instances.Pnr.Si539xSpi.callistoSpi" - , defTarget "Bittide.Instances.Pnr.Si539xSpi.si5391Spi" - , defTarget "Bittide.Instances.Pnr.StabilityChecker.stabilityChecker_3_1M" - , defTarget "Bittide.Instances.Pnr.Synchronizer.safeDffSynchronizer" - , (defTarget "Bittide.Instances.Pnr.Ethernet.vexRiscEthernet") - { targetHasXdc = True - , targetExternalHdl = - [ "$env(VERILOG_ETHERNET_SRC)/rtl/*.v" - , "$env(VERILOG_ETHERNET_SRC)/lib/axis/rtl/*.v" - ] - , targetExtraXdc = - [ "jtag_config.xdc", "jtag_pmod1.xdc", "sgmii.xdc"] - } - - , (testTarget "Bittide.Instances.Hitl.BoardTest.boardTestExtended") - {targetPostProcess = Just "post-board-test-extended"} - , testTarget "Bittide.Instances.Hitl.BoardTest.boardTestSimple" - , testTarget "Bittide.Instances.Hitl.FincFdec.fincFdecTests" - , testTarget "Bittide.Instances.Hitl.FullMeshHwCc.fullMeshHwCcTest" - , testTarget "Bittide.Instances.Hitl.FullMeshHwCc.fullMeshHwCcWithRiscvTest" - , (testTarget "Bittide.Instances.Hitl.FullMeshSwCc.fullMeshSwCcTest") - {targetPostProcess = Just "post-fullMeshSwCcTest"} - , testTarget "Bittide.Instances.Hitl.HwCcTopologies.hwCcTopologyTest" - , testTarget "Bittide.Instances.Hitl.LinkConfiguration.linkConfigurationTest" - , testTarget "Bittide.Instances.Hitl.SyncInSyncOut.syncInSyncOut" - , testTarget "Bittide.Instances.Hitl.Tcl.ExtraProbes.extraProbesTest" - , testTarget "Bittide.Instances.Hitl.Transceivers.transceiversUpTest" - , (testTarget "Bittide.Instances.Hitl.VexRiscv.vexRiscvTest") - { targetPostProcess = Just "post-vex-riscv-test" - , targetExtraXdc = ["jtag_config.xdc", "jtag_pmod1.xdc"] - } - ] +targets = + map + enforceValidTarget + [ defTarget "Bittide.Instances.Pnr.Calendar.switchCalendar1k" + , defTarget "Bittide.Instances.Pnr.Calendar.switchCalendar1kReducedPins" + , defTarget "Bittide.Instances.Pnr.ClockControl.callisto3" + , defTarget "Bittide.Instances.Pnr.Counter.counterReducedPins" + , defTarget "Bittide.Instances.Pnr.ElasticBuffer.elasticBuffer5" + , defTarget "Bittide.Instances.Pnr.ScatterGather.gatherUnit1K" + , defTarget "Bittide.Instances.Pnr.ScatterGather.gatherUnit1KReducedPins" + , defTarget "Bittide.Instances.Pnr.ScatterGather.scatterUnit1K" + , defTarget "Bittide.Instances.Pnr.ScatterGather.scatterUnit1KReducedPins" + , defTarget "Bittide.Instances.Pnr.Si539xSpi.callistoSpi" + , defTarget "Bittide.Instances.Pnr.Si539xSpi.si5391Spi" + , defTarget "Bittide.Instances.Pnr.StabilityChecker.stabilityChecker_3_1M" + , defTarget "Bittide.Instances.Pnr.Synchronizer.safeDffSynchronizer" + , (defTarget "Bittide.Instances.Pnr.Ethernet.vexRiscEthernet") + { targetHasXdc = True + , targetExternalHdl = + [ "$env(VERILOG_ETHERNET_SRC)/rtl/*.v" + , "$env(VERILOG_ETHERNET_SRC)/lib/axis/rtl/*.v" + ] + , targetExtraXdc = + ["jtag_config.xdc", "jtag_pmod1.xdc", "sgmii.xdc"] + } + , (testTarget "Bittide.Instances.Hitl.BoardTest.boardTestExtended") + { targetPostProcess = Just "post-board-test-extended" + } + , testTarget "Bittide.Instances.Hitl.BoardTest.boardTestSimple" + , testTarget "Bittide.Instances.Hitl.FincFdec.fincFdecTests" + , testTarget "Bittide.Instances.Hitl.FullMeshHwCc.fullMeshHwCcTest" + , testTarget "Bittide.Instances.Hitl.FullMeshHwCc.fullMeshHwCcWithRiscvTest" + , (testTarget "Bittide.Instances.Hitl.FullMeshSwCc.fullMeshSwCcTest") + { targetPostProcess = Just "post-fullMeshSwCcTest" + } + , testTarget "Bittide.Instances.Hitl.HwCcTopologies.hwCcTopologyTest" + , testTarget "Bittide.Instances.Hitl.LinkConfiguration.linkConfigurationTest" + , testTarget "Bittide.Instances.Hitl.SyncInSyncOut.syncInSyncOut" + , testTarget "Bittide.Instances.Hitl.Tcl.ExtraProbes.extraProbesTest" + , testTarget "Bittide.Instances.Hitl.Transceivers.transceiversUpTest" + , (testTarget "Bittide.Instances.Hitl.VexRiscv.vexRiscvTest") + { targetPostProcess = Just "post-vex-riscv-test" + , targetExtraXdc = ["jtag_config.xdc", "jtag_pmod1.xdc"] + } + ] shakeOpts :: ShakeOptions -shakeOpts = shakeOptions - { shakeFiles = buildDir - , shakeChange = ChangeDigest - , shakeVersion = "11" - } +shakeOpts = + shakeOptions + { shakeFiles = buildDir + , shakeChange = ChangeDigest + , shakeVersion = "11" + } -- | Run Vivado on given TCL script. Can collect the ExitCode. -vivadoFromTcl :: CmdResult r => FilePath -> Action r +vivadoFromTcl :: (CmdResult r) => FilePath -> Action r vivadoFromTcl tclPath = command [AddEnv "XILINX_LOCAL_USER_DATA" "no"] -- Prevents multiprocessing issues @@ -252,27 +251,30 @@ vivadoFromTcl_ tclPath = "vivado" ["-mode", "batch", "-source", tclPath, "-notrace"] --- | Constructs a 'BoardPart' based on environment variables @SYNTHESIS_BOARD@ --- or @SYNTHESIS_PART@. Errors if both are set, returns a default (free) part --- if neither is set. +{- | Constructs a 'BoardPart' based on environment variables @SYNTHESIS_BOARD@ +or @SYNTHESIS_PART@. Errors if both are set, returns a default (free) part +if neither is set. +-} getBoardPart :: Action BoardPart getBoardPart = do boardName <- getEnv "SYNTHESIS_BOARD" partName <- getEnv "SYNTHESIS_PART" case (boardName, partName) of - (Just b, Nothing) -> pure $ Board b - (Nothing, Just p) -> pure $ Part p + (Just b, Nothing) -> pure $ Board b + (Nothing, Just p) -> pure $ Part p (Nothing, Nothing) -> pure $ Part "xcku035-ffva1156-2-e" - (Just _b, Just _p) -> + (Just _b, Just _p) -> error "Both 'SYNTHESIS_BOARD' and 'SYNTHESIS_PART' are set, unset either and retry" --- | Inspect DRC and timing report. Throw an error if suspicious strings were --- found. +{- | Inspect DRC and timing report. Throw an error if suspicious strings were +found. +-} meetsDrcOrError :: FilePath -> FilePath -> FilePath -> IO () meetsDrcOrError methodologyPath summaryPath checkpointPath = unlessM (liftA2 (&&) (meetsTiming methodologyPath) (meetsTiming summaryPath)) - (error [I.i| + ( error + [I.i| Design did not meet design rule checks (DRC). Check out the timing summary at: #{summaryPath} @@ -285,12 +287,14 @@ meetsDrcOrError methodologyPath summaryPath checkpointPath = vivado #{checkpointPath} - |]) + |] + ) -- | Newtype used for adding oracle rules for flags to Shake newtype HardwareTargetsFlag = HardwareTargetsFlag () deriving (Show) deriving newtype (Eq, Typeable, Hashable, Binary, NFData) + type instance RuleResult HardwareTargetsFlag = HardwareTargets newtype ForceTestRerun = ForceTestRerun () @@ -298,27 +302,26 @@ newtype ForceTestRerun = ForceTestRerun () deriving newtype (Eq, Typeable, Hashable, Binary, NFData) type instance RuleResult ForceTestRerun = Bool --- | Defines a Shake build executable for calling Vivado. Like Make, in Shake --- you define rules that explain how to build a certain file. For example: --- --- manifestPath %> ... --- --- means: to build @manifestPath@ I need to do dot-dot-dot. See the README for --- an overview of which commands are user-passable (or simply scroll down). --- --- For a fundamental introduction into Shake, read the (lightweight!) paper --- introducing it: --- --- https://ndmitchell.com/downloads/paper-shake_before_building-10_sep_2012.pdf. --- --- Or, see https://shakebuild.com/. --- +{- | Defines a Shake build executable for calling Vivado. Like Make, in Shake +you define rules that explain how to build a certain file. For example: + + manifestPath %> ... + +means: to build @manifestPath@ I need to do dot-dot-dot. See the README for +an overview of which commands are user-passable (or simply scroll down). + +For a fundamental introduction into Shake, read the (lightweight!) paper +introducing it: + + https://ndmitchell.com/downloads/paper-shake_before_building-10_sep_2012.pdf. + +Or, see https://shakebuild.com/. +-} main :: IO () main = do setCurrentDirectory =<< findProjectRoot shakeArgsWith shakeOpts customFlags $ \flags shakeTargets -> pure $ Just $ do - let Options{..} = foldl (&) defaultOptions flags @@ -334,15 +337,21 @@ main = do (hitlBuildDir "*.yml") %> \path -> do needWatchFiles let entity = takeFileName (dropExtension path) - command_ [] "cabal" - [ "run", "--" + command_ + [] + "cabal" + [ "run" + , "--" , "bittide-tools:hitl-config-gen" - , "write", entity + , "write" + , entity ] (dataFilesDir "**") %> \_ -> do Stdout out <- - command [] "cabal" + command + [] + "cabal" [ "sdist" , "bittide" , "bittide-extra" @@ -350,18 +359,21 @@ main = do , "bittide-instances" , "bittide-tools" ] - command_ [] "mkdir" ["-p", dataFilesDir ] - for_ (filter (((==) (Just '/')) . fmap fst . uncons) $ lines out) - $ \sdist -> do - (Exit (_ :: ExitCode), Stderr ()) <- command [] "tar" - [ "--strip-components=2" - , "--overwrite" - , "-C" - , dataFilesDir - , "-xf" - , sdist - , takeBaseName (takeBaseName sdist) "data" - ] + command_ [] "mkdir" ["-p", dataFilesDir] + for_ (filter (((==) (Just '/')) . fmap fst . uncons) $ lines out) $ + \sdist -> do + (Exit (_ :: ExitCode), Stderr ()) <- + command + [] + "tar" + [ "--strip-components=2" + , "--overwrite" + , "-C" + , dataFilesDir + , "-xf" + , sdist + , takeBaseName (takeBaseName sdist) "data" + ] return () -- Files used for cache invalidation @@ -372,7 +384,7 @@ main = do -- For each target, generate a user callable command (PHONY). Run with -- '--help' to list them. - for_ targets $ \Target{..}-> do + for_ targets $ \Target{..} -> do let -- TODO: Dehardcode these paths. They're currently hardcoded in both the -- TCL and here, which smells. @@ -383,12 +395,12 @@ main = do reportDir = synthesisDir "reports" ilaDir = synthesisDir "ila-data" - runSynthTclPath = synthesisDir "run_synth.tcl" + runSynthTclPath = synthesisDir "run_synth.tcl" runPlaceAndRouteTclPath = synthesisDir "run_place_and_route.tcl" - runBitstreamTclPath = synthesisDir "run_bitstream.tcl" - runProbesGenTclPath = synthesisDir "run_probes_gen.tcl" - runBoardProgramTclPath = synthesisDir "run_board_program.tcl" - runHardwareTestTclPath = synthesisDir "run_hardware_test.tcl" + runBitstreamTclPath = synthesisDir "run_bitstream.tcl" + runProbesGenTclPath = synthesisDir "run_probes_gen.tcl" + runBoardProgramTclPath = synthesisDir "run_board_program.tcl" + runHardwareTestTclPath = synthesisDir "run_hardware_test.tcl" postSynthCheckpointPath = checkpointsDir "post_synth.dcp" postPlaceCheckpointPath = checkpointsDir "post_place.dcp" @@ -468,22 +480,22 @@ main = do xdcNames = entityName targetName <> ".xdc" : targetExtraXdc xdcPaths = map ((dataFilesDir "constraints") ) xdcNames constraints <- - if targetHasXdc then do - need xdcPaths - pure xdcPaths - else - pure [] + if targetHasXdc + then do + need xdcPaths + pure xdcPaths + else pure [] synthesisPart <- getBoardPart locatedManifest <- decodeLocatedManifest manifestPath tcl <- mkSynthesisTcl - synthesisDir -- Output directory for Vivado - False -- Out of context run - synthesisPart -- Part we're synthesizing for - constraints -- List of filenames with constraints - targetExternalHdl -- List of external HDL files to be included in synthesis + synthesisDir -- Output directory for Vivado + False -- Out of context run + synthesisPart -- Part we're synthesizing for + constraints -- List of filenames with constraints + targetExternalHdl -- List of external HDL files to be included in synthesis locatedManifest writeFileChanged path tcl @@ -501,22 +513,25 @@ main = do runPlaceAndRouteTclPath %> \path -> do writeFileChanged path (mkPlaceAndRouteTcl synthesisDir) - ( postPlaceCheckpointPath - : postRouteCheckpointPath - : routeReportsPaths - <> netlistPaths - ) |%> \_ -> do - need [runPlaceAndRouteTclPath, postSynthCheckpointPath] - vivadoFromTcl_ runPlaceAndRouteTclPath - - -- Design should meet design rule checks (DRC). - liftIO $ unlessM - ( liftA2 - (&&) - (meetsTiming postRouteMethodologyPath) - (meetsTiming postRouteTimingSummaryPath) - ) - (error [I.i| + ( postPlaceCheckpointPath + : postRouteCheckpointPath + : routeReportsPaths + <> netlistPaths + ) + |%> \_ -> do + need [runPlaceAndRouteTclPath, postSynthCheckpointPath] + vivadoFromTcl_ runPlaceAndRouteTclPath + + -- Design should meet design rule checks (DRC). + liftIO $ + unlessM + ( liftA2 + (&&) + (meetsTiming postRouteMethodologyPath) + (meetsTiming postRouteTimingSummaryPath) + ) + ( error + [I.i| Design did not meet design rule checks (DRC). Check out the timing summary at: #{postRouteTimingSummaryPath} @@ -533,14 +548,17 @@ main = do shake #{targetName}:pnr - |]) + |] + ) - -- Design should meet timing post routing. Note that this is not a - -- requirement after synthesis as many of the optimizations only follow - -- after. - liftIO $ unlessM - (meetsTiming postRouteTimingSummaryPath) - (error [I.i| + -- Design should meet timing post routing. Note that this is not a + -- requirement after synthesis as many of the optimizations only follow + -- after. + liftIO $ + unlessM + (meetsTiming postRouteTimingSummaryPath) + ( error + [I.i| Design did not meet timing. Check out the timing summary at: #{postRouteTimingSummaryPath} @@ -557,7 +575,8 @@ main = do shake #{targetName}:pnr - |]) + |] + ) -- Bitstream generation runBitstreamTclPath %> \path -> do @@ -608,11 +627,11 @@ main = do exitCode <- vivadoFromTcl @ExitCode runHardwareTestTclPath writeFileChanged path $ show exitCode - shortenNamesPy <- liftIO $ - Shake.getDataFileName ("data" "scripts" "shorten_names.py") + shortenNamesPy <- + liftIO $ + Shake.getDataFileName ("data" "scripts" "shorten_names.py") command_ [] "python3" [shortenNamesPy] - -- User friendly target names phony (entityName targetName <> ":hdl") $ do need [manifestPath] @@ -648,8 +667,6 @@ main = do exitCode <- read <$> readFile' testExitCodePath liftIO $ doPostProcessing (fromJust targetPostProcess) ilaDir exitCode - - if null shakeTargets then - rules - else - want shakeTargets >> withoutActions rules + if null shakeTargets + then rules + else want shakeTargets >> withoutActions rules diff --git a/bittide-shake/src/Clash/Shake/Extra.hs b/bittide-shake/src/Clash/Shake/Extra.hs index 9582b7666..ee9d8c451 100644 --- a/bittide-shake/src/Clash/Shake/Extra.hs +++ b/bittide-shake/src/Clash/Shake/Extra.hs @@ -2,10 +2,10 @@ -- -- SPDX-License-Identifier: Apache-2.0 --- | Shake utilities related to Clash. Although 'clash-shake' already exists, it --- assumes Clash runs in non-project mode. We should discuss with the author if --- he sees a way of upstreaming the code in this module. --- +{- | Shake utilities related to Clash. Although 'clash-shake' already exists, it +assumes Clash runs in non-project mode. We should discuss with the author if +he sees a way of upstreaming the code in this module. +-} module Clash.Shake.Extra where import Prelude @@ -18,8 +18,8 @@ import Development.Shake.FilePath (()) import qualified Crypto.Hash.SHA256 as Sha256 import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as ByteStringLazy -import qualified Data.Text.Encoding as Encoding import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding hdlToFlag :: HDL -> String hdlToFlag = ("--" <>) . map toLower . show @@ -29,16 +29,17 @@ hexDigestFile :: FilePath -> Action String hexDigestFile path = do need [path] contents <- liftIO (ByteStringLazy.readFile path) - pure - $ Text.unpack - $ Encoding.decodeUtf8 - $ Base16.encode - $ Sha256.hashlazy - $ contents + pure $ + Text.unpack $ + Encoding.decodeUtf8 $ + Base16.encode $ + Sha256.hashlazy $ + contents --- | Generate command to run and arguments to supply for a top entity passed as --- a @TemplateHaskell@ name. Generates the expected location of a Clash manifest --- file. +{- | Generate command to run and arguments to supply for a top entity passed as +a @TemplateHaskell@ name. Generates the expected location of a Clash manifest +file. +-} clashCmd :: -- | Build directory FilePath -> @@ -56,13 +57,17 @@ clashCmd buildDir hdl topName extraArgs = , pkgName <> ":clash" , "--" , modName - , "-fclash-hdldir", buildDir - , "-main-is", funcName + , "-fclash-hdldir" + , buildDir + , "-main-is" + , funcName , hdlToFlag hdl , "-fclash-clear" , "-fclash-spec-limit=100" - , "-fclash-debug", "DebugSilent" - ] <> extraArgs + , "-fclash-debug" + , "DebugSilent" + ] + <> extraArgs ) where (modName, funcName) = splitName topName @@ -74,8 +79,8 @@ type TargetName = String -- | Split a 'TargetName' into the fully qualified module name and the function name. splitName :: TargetName -> (String, String) splitName qualifiedName = - let (f, m) = break (== '.') $ reverse qualifiedName - in (reverse $ tail m, reverse f) + let (f, m) = break (== '.') $ reverse qualifiedName + in (reverse $ tail m, reverse f) entityName :: TargetName -> String entityName = snd . splitName diff --git a/bittide-shake/src/Clash/Shake/Flags.hs b/bittide-shake/src/Clash/Shake/Flags.hs index c7229f1a3..161d724be 100644 --- a/bittide-shake/src/Clash/Shake/Flags.hs +++ b/bittide-shake/src/Clash/Shake/Flags.hs @@ -1,19 +1,18 @@ +{-# LANGUAGE DeriveAnyClass #-} -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -- | Flags used by Shake module Clash.Shake.Flags where import Prelude -import Text.Read (readMaybe) -import System.Console.GetOpt (OptDescr(Option), ArgDescr(ReqArg, NoArg)) -import GHC.Generics (Generic) import Development.Shake.Classes +import GHC.Generics (Generic) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), OptDescr (Option)) +import Text.Read (readMaybe) data Options = Options { hardwareTargets :: HardwareTargets @@ -21,39 +20,41 @@ data Options = Options } defaultOptions :: Options -defaultOptions = Options - { hardwareTargets = OneAny - , forceTestRerun = False - } +defaultOptions = + Options + { hardwareTargets = OneAny + , forceTestRerun = False + } -- | Number of hardware targets to program and optionally test data HardwareTargets - -- | Program the first FPGA found by Vivado. This is not necessarily the first - -- FPGA in the demo rack. - = OneAny - -- | Program the FPGAs in the demo rack at the specific indices. The actual - -- IDs of the FPGAs in the demo rack are specified in @HardwareTest.tcl@. - | Specific [Int] - -- | Program all connected FPGAs. Note that we currently hardcode a list of all - -- FPGAs in our possesion. If we can't find them all, the program will exit with - -- and error code. - | All + = -- | Program the first FPGA found by Vivado. This is not necessarily the first + -- FPGA in the demo rack. + OneAny + | -- | Program the FPGAs in the demo rack at the specific indices. The actual + -- IDs of the FPGAs in the demo rack are specified in @HardwareTest.tcl@. + Specific [Int] + | -- | Program all connected FPGAs. Note that we currently hardcode a list of all + -- FPGAs in our possesion. If we can't find them all, the program will exit with + -- and error code. + All deriving (Read, Show, Eq, Typeable, Generic, Hashable, Binary, NFData) - --- | Parse string to 'HardwareTargets'. Return 'Left' if given string could not --- be parsed. +{- | Parse string to 'HardwareTargets'. Return 'Left' if given string could not +be parsed. +-} parseHardwareTargetsFlag :: String -> Either String (Options -> Options) parseHardwareTargetsFlag s = case readMaybe s of Just f -> case f of Specific [] -> Left ("Specify at least one index from the demo rack, or use OneAny") - _ -> Right (\opts -> opts {hardwareTargets = f}) + _ -> Right (\opts -> opts{hardwareTargets = f}) Nothing -> Left ("Not a valid hardware target: " ++ s) --- | List of custom flags supported by us. Note that we currently support only --- one flag, 'HardwareTargets'. +{- | List of custom flags supported by us. Note that we currently support only +one flag, 'HardwareTargets'. +-} customFlags :: [OptDescr (Either String (Options -> Options))] customFlags = [ Option @@ -64,6 +65,6 @@ customFlags = , Option "" -- no short flags ["force-test-rerun"] - (NoArg $ Right (\opts -> opts { forceTestRerun = True })) + (NoArg $ Right (\opts -> opts{forceTestRerun = True})) "Force the rerun of hardware in the loop tests" ] diff --git a/bittide-shake/src/Clash/Shake/Vivado.hs b/bittide-shake/src/Clash/Shake/Vivado.hs index 140ebc569..90815a987 100644 --- a/bittide-shake/src/Clash/Shake/Vivado.hs +++ b/bittide-shake/src/Clash/Shake/Vivado.hs @@ -1,51 +1,50 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} --- | Generate a TCL script to simulate generated VHDL --- --- Run with @vivado -mode batch -source ...@ --- -module Clash.Shake.Vivado - ( LocatedManifest(..) - , BoardPart(..) - , TclGlobPattern - , decodeLocatedManifest - , mkSynthesisTcl - , mkPlaceAndRouteTcl - , mkBitstreamTcl - , mkProbesGenTcl - , mkBoardProgramTcl - , mkHardwareTestTcl - , meetsTiming - , meetsDrc - ) where +{- | Generate a TCL script to simulate generated VHDL + +Run with @vivado -mode batch -source ...@ +-} +module Clash.Shake.Vivado ( + LocatedManifest (..), + BoardPart (..), + TclGlobPattern, + decodeLocatedManifest, + mkSynthesisTcl, + mkPlaceAndRouteTcl, + mkBitstreamTcl, + mkProbesGenTcl, + mkBoardProgramTcl, + mkHardwareTestTcl, + meetsTiming, + meetsDrc, +) where import Prelude import Development.Shake import Development.Shake.Extra (decodeFile) -import Control.Monad.Extra (andM, orM) import Clash.DataFiles (tclConnector) import Clash.Driver.Manifest -import Data.List (isInfixOf, intercalate) +import Control.Monad.Extra (andM, orM) +import Data.List (intercalate, isInfixOf) import Data.String.Interpolate (__i) -import System.FilePath ((), dropFileName) +import System.FilePath (dropFileName, ()) import Clash.Shake.Extra (hexDigestFile) -import Clash.Shake.Flags (HardwareTargets(..)) +import Clash.Shake.Flags (HardwareTargets (..)) import Paths_bittide_shake -- | Satisfied if all actions result in 'False' -noneM :: Monad m => [m Bool] -> m Bool +noneM :: (Monad m) => [m Bool] -> m Bool noneM = fmap not . orM -- | Whether a string occurs in a file @@ -54,38 +53,41 @@ inFile msg path = do content <- readFile path pure $ (msg `isInfixOf` content) --- | Read a timing summary or DRC report and determine whether it passed DRC --- checks. +{- | Read a timing summary or DRC report and determine whether it passed DRC +checks. +-} meetsDrc :: FilePath -> IO Bool -meetsDrc path = noneM - [ inFile "No report available as report_methodology has not been run prior." path - , inFile "Critical Warning" path - ] +meetsDrc path = + noneM + [ inFile "No report available as report_methodology has not been run prior." path + , inFile "Critical Warning" path + ] -- | Read a timing summary and determine whether it met timing. meetsTiming :: FilePath -> IO Bool -meetsTiming path = andM - [ meetsDrc path -- for safety; users should use meetDrc for useful error reporting - , fmap not $ inFile "Timing constraints are not met" path - ] +meetsTiming path = + andM + [ meetsDrc path -- for safety; users should use meetDrc for useful error reporting + , fmap not $ inFile "Timing constraints are not met" path + ] -- | Patterns compatible with https://www.tcl.tk/man/tcl8.6/TclCmd/glob.htm type TclGlobPattern = String -- TODO: Upstream data LocatedManifest = LocatedManifest - { -- | Path pointing to the manifest file itself - lmPath :: FilePath - - -- | Manifest file corresponding to the one at 'lmPath' + { lmPath :: FilePath + -- ^ Path pointing to the manifest file itself , lmManifest :: Manifest + -- ^ Manifest file corresponding to the one at 'lmPath' } decodeLocatedManifest :: FilePath -> Action LocatedManifest decodeLocatedManifest path = LocatedManifest path <$> decodeFile path --- | Vivado board part or part. If a board part is set, Vivado will infer the --- part on that board. +{- | Vivado board part or part. If a board part is set, Vivado will infer the +part on that board. +-} data BoardPart = Board String | Part String @@ -96,10 +98,10 @@ mkBoardPartTcl boardPart = case boardPart of (Board name) -> "set_property board_part " <> name <> " [current_project]" (Part name) -> "set_property part " <> name <> " [current_project]" --- | Generates TCL that generates and reads Xilinx IP and reads constraints and --- HDL files generated by Clash. The caller is responsible for starting synthesis --- or simulation. --- +{- | Generates TCL that generates and reads Xilinx IP and reads constraints and +HDL files generated by Clash. The caller is responsible for starting synthesis +or simulation. +-} mkBaseTcl :: -- | Where to create ip directory. FilePath -> @@ -120,7 +122,8 @@ mkBaseTcl outputDir globPatterns LocatedManifest{lmPath} boardPart = do boardPartTcl = mkBoardPartTcl boardPart globTcl | null globPatterns = "" :: String - | otherwise = [__i| + | otherwise = + [__i| set extra_hdl_files [list] \# We use file join to be able to retrieve environment variables \# from our paths @@ -132,7 +135,8 @@ mkBaseTcl outputDir globPatterns LocatedManifest{lmPath} boardPart = do add_files $extra_hdl_files |] - pure [__i| + pure + [__i| \# #{lmPath}: #{lmPathDigest} \# #{connector}: #{connectorDigest} set_msg_config -severity {CRITICAL WARNING} -new_severity ERROR @@ -179,11 +183,19 @@ mkSynthesisTcl :: LocatedManifest -> -- | Rendered TCL Action String -mkSynthesisTcl outputDir outOfContext boardPart constraints globPatterns +mkSynthesisTcl + outputDir + outOfContext + boardPart + constraints + globPatterns manifest@LocatedManifest{lmManifest} = do - baseTcl <- mkBaseTcl outputDir globPatterns manifest boardPart - constraintDigests <- unlines <$> mapM constraintDigest constraints - pure $ baseTcl <> "\n" <> [__i| + baseTcl <- mkBaseTcl outputDir globPatterns manifest boardPart + constraintDigests <- unlines <$> mapM constraintDigest constraints + pure $ + baseTcl + <> "\n" + <> [__i| #{constraintDigests} set_msg_config -severity {CRITICAL WARNING} -new_severity ERROR @@ -203,20 +215,21 @@ mkSynthesisTcl outputDir outOfContext boardPart constraints globPatterns write_verilog -force {#{outputDir "netlist" "netlist.v"}} write_xdc -no_fixed_only -force {#{outputDir "netlist" "netlist.xdc"}} |] - where - name = topComponent lmManifest - outOfContextStr - | outOfContext = "out_of_context" :: String - | otherwise = "default" - constraintReader constr = "read_xdc -unmanaged {" <> constr <> "}\n" - constraintsString = concatMap constraintReader constraints - - constraintDigest path = do - pathDigest <- hexDigestFile path - pure [__i|\# #{path}: #{pathDigest}|] + where + name = topComponent lmManifest + outOfContextStr + | outOfContext = "out_of_context" :: String + | otherwise = "default" + constraintReader constr = "read_xdc -unmanaged {" <> constr <> "}\n" + constraintsString = concatMap constraintReader constraints + + constraintDigest path = do + pathDigest <- hexDigestFile path + pure [__i|\# #{path}: #{pathDigest}|] mkPlaceAndRouteTcl :: FilePath -> String -mkPlaceAndRouteTcl outputDir = [__i| +mkPlaceAndRouteTcl outputDir = + [__i| set_msg_config -severity {CRITICAL WARNING} -new_severity ERROR \# Pick up where synthesis left off @@ -247,7 +260,8 @@ mkPlaceAndRouteTcl outputDir = [__i| |] mkBitstreamTcl :: FilePath -> String -mkBitstreamTcl outputDir = [__i| +mkBitstreamTcl outputDir = + [__i| set_msg_config -severity {CRITICAL WARNING} -new_severity ERROR \# Pick up where netlist left off @@ -259,7 +273,8 @@ mkBitstreamTcl outputDir = [__i| |] mkProbesGenTcl :: FilePath -> String -mkProbesGenTcl outputDir = [__i| +mkProbesGenTcl outputDir = + [__i| set_msg_config -severity {CRITICAL WARNING} -new_severity ERROR \# Pick up where netlist left off @@ -269,17 +284,19 @@ mkProbesGenTcl outputDir = [__i| write_debug_probes -force {#{outputDir "probes.ltx"}} |] --- | Convert HardwareTargets to a Tcl list of target FPGAs. To be used in --- combination with `fpga_ids` in `HardwareTest.tcl` +{- | Convert HardwareTargets to a Tcl list of target FPGAs. To be used in +combination with `fpga_ids` in `HardwareTest.tcl` +-} toTclTarget :: HardwareTargets -> String toTclTarget hwTargets = let listToTcl :: [Int] -> String listToTcl xs = "[list " <> (intercalate " " $ map show xs) <> "]" - in case hwTargets of - OneAny -> listToTcl [] - Specific xs -> listToTcl $ map (`mod` 8) xs - All -> listToTcl [0..7] + in + case hwTargets of + OneAny -> listToTcl [] + Specific xs -> listToTcl $ map (`mod` 8) xs + All -> listToTcl [0 .. 7] mkBoardProgramTcl :: -- | Directory where the bitstream file are located @@ -301,7 +318,8 @@ mkBoardProgramTcl outputDir hwTargets url hasProbesFile = do | hasProbesFile = [__i|set probes_file {#{outputDir "probes.ltx"}}|] | otherwise = "set probes_file {}" - pure [__i| + pure + [__i| source {#{hardwareTestTclPath}} -notrace global fpga_ids @@ -324,7 +342,6 @@ mkBoardProgramTcl outputDir hwTargets url hasProbesFile = do } |] - mkHardwareTestTcl :: -- | Path to test configuration FilePath -> @@ -340,7 +357,8 @@ mkHardwareTestTcl :: IO String mkHardwareTestTcl testConfigPath outputDir hwTargets url ilaDataPath = do hardwareTestTclPath <- getDataFileName ("data" "tcl" "HardwareTest.tcl") - pure [__i| + pure + [__i| source {#{hardwareTestTclPath}} -notrace set_msg_config -severity {CRITICAL WARNING} -new_severity ERROR diff --git a/bittide-shake/src/Development/Shake/Extra.hs b/bittide-shake/src/Development/Shake/Extra.hs index 8666af6c0..0a1d10923 100644 --- a/bittide-shake/src/Development/Shake/Extra.hs +++ b/bittide-shake/src/Development/Shake/Extra.hs @@ -14,7 +14,7 @@ import qualified Data.Aeson as Aeson suppressOutput :: [CmdOption] suppressOutput = [EchoStdout False, EchoStderr True] -decodeFile :: Aeson.FromJSON a => FilePath -> Action a +decodeFile :: (Aeson.FromJSON a) => FilePath -> Action a decodeFile path = do need [path] fromJust <$> liftIO (Aeson.decodeFileStrict path) diff --git a/bittide-shake/src/Paths/Bittide/Shake.hs b/bittide-shake/src/Paths/Bittide/Shake.hs index 145209fff..c58262142 100644 --- a/bittide-shake/src/Paths/Bittide/Shake.hs +++ b/bittide-shake/src/Paths/Bittide/Shake.hs @@ -2,8 +2,8 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Paths.Bittide.Shake - ( module Paths_bittide_shake - ) where +module Paths.Bittide.Shake ( + module Paths_bittide_shake, +) where -import Paths_bittide_shake \ No newline at end of file +import Paths_bittide_shake diff --git a/bittide-shake/tests/doctests.hs b/bittide-shake/tests/doctests.hs index cfe23c4e2..16e12f876 100644 --- a/bittide-shake/tests/doctests.hs +++ b/bittide-shake/tests/doctests.hs @@ -4,11 +4,11 @@ module Main where -import Test.DocTest (mainFromCabal) import System.Environment (getArgs) +import Test.DocTest (mainFromCabal) main :: IO () main = do -- We use Nix to setup tooling, not to provide GHC packages so we need to set --no-nix args <- getArgs - mainFromCabal "bittide-shake" ("--no-nix":args) + mainFromCabal "bittide-shake" ("--no-nix" : args) diff --git a/bittide-tools/clockcontrol/plot/Main.hs b/bittide-tools/clockcontrol/plot/Main.hs index bcbe62b34..a8600b1e9 100644 --- a/bittide-tools/clockcontrol/plot/Main.hs +++ b/bittide-tools/clockcontrol/plot/Main.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -9,227 +8,286 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} module Main (main, knownTestsWithSimConf) where -import Clash.Prelude - ( BitPack(..), SNat(..), Vec, Index - , checkedTruncateB, clockPeriod, extend - , natToInteger, natToNum, snatProxy, snatToInteger - ) - -import Clash.Signal.Internal (Femtoseconds(..)) -import qualified Clash.Sized.Vector as Vec - ( (!!), imap, unsafeFromList, toList, repeat, replace - , zip, zipWith, indicesI, length, take - ) - +import Clash.Prelude ( + BitPack (..), + Index, + SNat (..), + Vec, + checkedTruncateB, + clockPeriod, + extend, + natToInteger, + natToNum, + snatProxy, + snatToInteger, + ) + +import Clash.Signal.Internal (Femtoseconds (..)) +import Clash.Sized.Vector qualified as Vec ( + imap, + indicesI, + length, + repeat, + replace, + take, + toList, + unsafeFromList, + zip, + zipWith, + (!!), + ) + +import Data.Type.Equality ((:~:) (..)) import GHC.TypeLits -import Data.Type.Equality ((:~:)(..)) -import GHC.TypeLits.Compare ((:<=?)(..)) +import GHC.TypeLits.Compare ((:<=?) (..)) import GHC.TypeLits.Witnesses ((%<=?)) -import GHC.TypeLits.Witnesses qualified as TLW (SNat(..)) - -import Conduit - ( ConduitT, Void, (.|) - , runConduit, sourceHandle, scanlC, dropC, mapC, sinkList, yield, await - ) +import GHC.TypeLits.Witnesses qualified as TLW (SNat (..)) + +import Conduit ( + ConduitT, + Void, + await, + dropC, + mapC, + runConduit, + scanlC, + sinkList, + sourceHandle, + yield, + (.|), + ) import Control.Applicative (liftA2) import Control.Arrow (first) -import Control.Exception (Exception(..), catch, throw) -import Control.Monad (forM, forM_, filterM, when, unless) +import Control.Exception (Exception (..), catch, throw) +import Control.Monad (filterM, forM, forM_, unless, when) import Control.Monad.Extra (unlessM) -import Data.Bool import Data.Bifunctor (bimap) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.UTF8 as UTF8 +import Data.Bool +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.UTF8 qualified as UTF8 import Data.Char (isDigit) -import Data.Csv - ( FromField(..), FromNamedRecord(..), ToNamedRecord(..), (.:) - , defaultDecodeOptions, encodeByName - ) -import Data.Csv.Conduit - ( CsvStreamRecordParseError(..), CsvStreamHaltParseError(..) - , fromNamedCsvStreamError - ) +import Data.Csv ( + FromField (..), + FromNamedRecord (..), + ToNamedRecord (..), + defaultDecodeOptions, + encodeByName, + (.:), + ) +import Data.Csv.Conduit ( + CsvStreamHaltParseError (..), + CsvStreamRecordParseError (..), + fromNamedCsvStreamError, + ) import Data.Functor ((<&>)) -import Data.List (uncons, isPrefixOf, isSuffixOf, find) -import Data.Maybe (catMaybes, fromMaybe, fromJust, isNothing, mapMaybe) -import Data.Proxy (Proxy(..)) +import Data.HashMap.Strict qualified as HashMap (fromList, size) +import Data.List (find, isPrefixOf, isSuffixOf, uncons) +import Data.Map qualified as Map (toList) +import Data.Maybe (catMaybes, fromJust, fromMaybe, isNothing, mapMaybe) +import Data.Proxy (Proxy (..)) +import Data.Set qualified as Set ( + difference, + fromList, + isProperSubsetOf, + member, + toList, + ) import Data.String (fromString) -import qualified Data.Map as Map (toList) -import qualified Data.Text as Text (unpack) -import qualified Data.Vector as Vector (fromList) -import qualified Data.HashMap.Strict as HashMap (fromList, size) -import qualified Data.Set as Set - (fromList, toList, isProperSubsetOf, difference, member) -import GHC.IO.Exception (IOException(..), IOErrorType(..)) -import System.Directory - (listDirectory, doesDirectoryExist, createDirectoryIfMissing) +import Data.Text qualified as Text (unpack) +import Data.Vector qualified as Vector (fromList) +import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import System.Directory ( + createDirectoryIfMissing, + doesDirectoryExist, + listDirectory, + ) import System.Environment (getArgs, getProgName) import System.Exit (die) -import System.FilePath - ((), takeExtensions, takeBaseName, takeFileName, isExtensionOf) +import System.FilePath ( + isExtensionOf, + takeBaseName, + takeExtensions, + takeFileName, + (), + ) +import System.IO ( + BufferMode (..), + Handle, + IOMode (..), + hClose, + hFlush, + hPutStr, + hSetBuffering, + openFile, + withFile, + ) import "bittide-extra" Numeric.Extra (parseHex) -import System.IO ( BufferMode(..), IOMode(..), Handle, openFile, hClose - , withFile, hSetBuffering, hPutStr, hFlush - ) -import Bittide.Plot import Bittide.ClockControl import Bittide.ClockControl.StabilityChecker import Bittide.Github.Artifacts import Bittide.Hitl +import Bittide.Instances.Domains import Bittide.Instances.Hitl.IlaPlot import Bittide.Instances.Hitl.Setup import Bittide.Instances.Hitl.Tests -import Bittide.Instances.Domains +import Bittide.Plot import Bittide.Report.ClockControl -import Bittide.Simulate.Config (SimConf, simTopologyFileName, saveSimConfig) +import Bittide.Simulate.Config (SimConf, saveSimConfig, simTopologyFileName) import Bittide.Topology -import qualified Bittide.Simulate.Config as SimConf (SimConf(..)) +import Bittide.Simulate.Config qualified as SimConf (SimConf (..)) -- A newtype wrapper for working with hex encoded types. -newtype Hex a = Hex { fromHex :: a } +newtype Hex a = Hex {fromHex :: a} deriving newtype (BitPack) -instance BitPack a => FromField (Hex a) where +instance (BitPack a) => FromField (Hex a) where parseField = either fail pure . parseHex . UTF8.toString --- | The captured data entries, as they are dumped by the ILA of --- 'Bittide.Instances.Hitl.IlaPlot.callistoClockControlWithIla'. -data Capture (nodeCount :: Nat) (compressedElasticBufferBits :: Nat) = - Capture - { sampleInBuffer :: Int - , sampleInWindow :: Int - , trigger :: Hex Bool - , triggerSignal :: Hex Bool - , capture :: Hex Bool - , captureCond :: Hex CaptureCondition - , globalTimestamp :: Hex (GlobalTimestamp Basic125) - , localTimestamp :: Hex (DiffResult (LocalTimestamp GthTx)) - , plotData :: Hex (PlotData (nodeCount - 1) compressedElasticBufferBits) - } +{- | The captured data entries, as they are dumped by the ILA of +'Bittide.Instances.Hitl.IlaPlot.callistoClockControlWithIla'. +-} +data Capture (nodeCount :: Nat) (compressedElasticBufferBits :: Nat) = Capture + { sampleInBuffer :: Int + , sampleInWindow :: Int + , trigger :: Hex Bool + , triggerSignal :: Hex Bool + , capture :: Hex Bool + , captureCond :: Hex CaptureCondition + , globalTimestamp :: Hex (GlobalTimestamp Basic125) + , localTimestamp :: Hex (DiffResult (LocalTimestamp GthTx)) + , plotData :: Hex (PlotData (nodeCount - 1) compressedElasticBufferBits) + } instance - ( KnownNat nodeCount, KnownNat compressedElasticBufferBits + ( KnownNat nodeCount + , KnownNat compressedElasticBufferBits , 1 <= nodeCount ) => FromNamedRecord (Capture nodeCount compressedElasticBufferBits) - where + where parseNamedRecord v = if HashMap.size v /= 3 + Vec.length ilaProbeNames - then fail "Row with more than 8 fields" - else Capture - <$> v .: "Sample in Buffer" - <*> v .: "Sample in Window" - <*> v .: "TRIGGER" - <*> v .: portName 0 - <*> v .: portName 1 - <*> v .: portName 2 - <*> v .: portName 3 - <*> v .: portName 4 - <*> v .: portName 5 + then fail "Row with more than 8 fields" + else + Capture + <$> v .: "Sample in Buffer" + <*> v .: "Sample in Window" + <*> v .: "TRIGGER" + <*> v .: portName 0 + <*> v .: portName 1 + <*> v .: portName 2 + <*> v .: portName 3 + <*> v .: portName 4 + <*> v .: portName 5 where portName = portName# ilaProbeNames - portName# :: KnownNat n => Vec n String -> Index n -> BS.ByteString + portName# :: (KnownNat n) => Vec n String -> Index n -> BS.ByteString portName# names = fromString . (names Vec.!!) -- | A data point resulting from post processing the captured data. -data DataPoint (nodeCount :: Nat) (decompressedElasticBufferBits :: Nat) = - DataPoint - { dpIndex :: Int - -- ^ the index of the corresponding sample of the dump - , dpGlobalLast :: GlobalTimestamp Basic125 - -- ^ the global time stamp of the previous scheduled capture - , dpCycleDiff :: Femtoseconds - -- ^ the number of clock cycles since the last cheduled capture - , dpGlobalTime :: Femtoseconds - -- ^ the absolute number of femtoseconds since the start of the - -- dump according to the global synchronized clock - , dpLastScheduledGlobalTime :: Femtoseconds - -- ^ the absolute number of femtoseconds since the start of the - -- dump according to the global synchronized clock at the time - -- of the last scheduled capture - , dpLocalTime :: Femtoseconds - -- ^ the absolute number of femtoseconds since the start of the - -- dump according to the local clock - , dpLastScheduledLocalTime :: Femtoseconds - -- ^ the absolute number of femtoseconds since the start of the - -- dump according to the local clock at the time - -- of the last scheduled capture - , dpDrift :: Femtoseconds - -- ^ the drift between the global an the local clocks in - -- femtoseconds per scheduled capture period - , dpCCChanges :: Int - -- ^ the accumulated number FINC/FDECs integrated over time - , dpRfStage :: ReframingStage - -- ^ the reframing stage - , dpDataCounts :: Vec nodeCount - (Maybe (RelDataCount decompressedElasticBufferBits)) - -- ^ the elastic buffer data counts of the available links - , dpStability :: Vec nodeCount (Maybe StabilityIndication) - -- ^ the stability indicators for each of the elastic buffers - -- of the available links - } +data DataPoint (nodeCount :: Nat) (decompressedElasticBufferBits :: Nat) = DataPoint + { dpIndex :: Int + -- ^ the index of the corresponding sample of the dump + , dpGlobalLast :: GlobalTimestamp Basic125 + -- ^ the global time stamp of the previous scheduled capture + , dpCycleDiff :: Femtoseconds + -- ^ the number of clock cycles since the last cheduled capture + , dpGlobalTime :: Femtoseconds + -- ^ the absolute number of femtoseconds since the start of the + -- dump according to the global synchronized clock + , dpLastScheduledGlobalTime :: Femtoseconds + -- ^ the absolute number of femtoseconds since the start of the + -- dump according to the global synchronized clock at the time + -- of the last scheduled capture + , dpLocalTime :: Femtoseconds + -- ^ the absolute number of femtoseconds since the start of the + -- dump according to the local clock + , dpLastScheduledLocalTime :: Femtoseconds + -- ^ the absolute number of femtoseconds since the start of the + -- dump according to the local clock at the time + -- of the last scheduled capture + , dpDrift :: Femtoseconds + -- ^ the drift between the global an the local clocks in + -- femtoseconds per scheduled capture period + , dpCCChanges :: Int + -- ^ the accumulated number FINC/FDECs integrated over time + , dpRfStage :: ReframingStage + -- ^ the reframing stage + , dpDataCounts :: + Vec + nodeCount + (Maybe (RelDataCount decompressedElasticBufferBits)) + -- ^ the elastic buffer data counts of the available links + , dpStability :: Vec nodeCount (Maybe StabilityIndication) + -- ^ the stability indicators for each of the elastic buffers + -- of the available links + } instance - ( KnownNat nodeCount, KnownNat decompressedElasticBufferBits + ( KnownNat nodeCount + , KnownNat decompressedElasticBufferBits , 1 <= nodeCount ) => ToNamedRecord (DataPoint nodeCount decompressedElasticBufferBits) - where - toNamedRecord DataPoint{..} = HashMap.fromList $ - fmap (bimap BSC.pack BSC.pack) $ - [ ("Index", show dpIndex) - , ("Synchronized Time (fs)", show $ toInteger dpGlobalTime) - , ("Local Clock time (fs)", show $ toInteger dpLocalTime) - , ("Clock Period Drift (fs)", show $ toInteger dpDrift) - , ("Integrated FINC/FDECs", show dpCCChanges) - , ("Reframing State", rf2bs dpRfStage) - ] <> - [ ("EB " <> show i, show $ toInteger x) - | (i, x) <- topologyView dpDataCounts - ] <> - [ (show i <> " is stable", b2bs $ stable x) - | (i, x) <- topologyView dpStability - ] <> - [ (show i <> " is settled", b2bs $ settled x) - | (i, x) <- topologyView dpStability - ] + where + toNamedRecord DataPoint{..} = + HashMap.fromList $ + fmap (bimap BSC.pack BSC.pack) $ + [ ("Index", show dpIndex) + , ("Synchronized Time (fs)", show $ toInteger dpGlobalTime) + , ("Local Clock time (fs)", show $ toInteger dpLocalTime) + , ("Clock Period Drift (fs)", show $ toInteger dpDrift) + , ("Integrated FINC/FDECs", show dpCCChanges) + , ("Reframing State", rf2bs dpRfStage) + ] + <> [ ("EB " <> show i, show $ toInteger x) + | (i, x) <- topologyView dpDataCounts + ] + <> [ (show i <> " is stable", b2bs $ stable x) + | (i, x) <- topologyView dpStability + ] + <> [ (show i <> " is settled", b2bs $ settled x) + | (i, x) <- topologyView dpStability + ] where - topologyView = catMaybes - . Vec.toList - . fmap (\(i,x) -> (i,) <$> x) - . Vec.zip Vec.indicesI + topologyView = + catMaybes + . Vec.toList + . fmap (\(i, x) -> (i,) <$> x) + . Vec.zip Vec.indicesI b2bs = \case False -> "0" - True -> "1" + True -> "1" rf2bs = \case RSDetect -> "Detect" - RSWait -> "Wait" - RSDone -> "Done" + RSWait -> "Wait" + RSDone -> "Done" --- | Multiplies some 'Femtoseconds' with any numerical value. Note --- that this operation can produce negative values, which is --- intentional. +{- | Multiplies some 'Femtoseconds' with any numerical value. Note +that this operation can produce negative values, which is +intentional. +-} infix 9 ~* -(~*) :: Integral a => a -> Femtoseconds -> Femtoseconds + +(~*) :: (Integral a) => a -> Femtoseconds -> Femtoseconds a ~* (Femtoseconds b) = Femtoseconds $ fromInteger (toInteger a) * b deriving newtype instance Num Femtoseconds @@ -245,15 +303,14 @@ instance Exception CsvParseError postProcess :: forall topologySize - -- ^ the size of the topology underlying the data to be processed + -- \^ the size of the topology underlying the data to be processed decompressedElasticBufferBits - -- ^ the bitsize of the elastic buffer entries after decompression + -- \^ the bitsize of the elastic buffer entries after decompression utilizedFpgaCount - -- ^ the number of hardware nodes used to generated the data + -- \^ the number of hardware nodes used to generated the data compressedElasticBufferBits - -- ^ the bitsize of the elastic buffer entries before decompression - anyMonad - . + -- \^ the bitsize of the elastic buffer entries before decompression + anyMonad. ( KnownNat topologySize , KnownNat decompressedElasticBufferBits , KnownNat utilizedFpgaCount @@ -272,151 +329,172 @@ postProcess :: (DataPoint topologySize decompressedElasticBufferBits) anyMonad () -postProcess t i links = scanlC process initDummy - -- finally drop the dummy, the trigger and the calibration entries - .| (dropC 4 >> mapC id) +postProcess t i links = + scanlC process initDummy + -- finally drop the dummy, the trigger and the calibration entries + .| (dropC 4 >> mapC id) where topologyView :: Vec (utilizedFpgaCount - 1) a -> Vec topologySize (Maybe a) topologyView = - foldr (\(j, x) -> Vec.replace j $ Just x) (Vec.repeat Nothing) - . filter (hasEdge t i . fst) - . fmap ( first - $ checkedTruncateB @topologySize @(utilizedFpgaCount - topologySize) - ) - . filter ((<= natToNum @(topologySize - 1)) . fst) - . Vec.toList - . Vec.zip links + foldr (\(j, x) -> Vec.replace j $ Just x) (Vec.repeat Nothing) + . filter (hasEdge t i . fst) + . fmap + ( first $ + checkedTruncateB @topologySize @(utilizedFpgaCount - topologySize) + ) + . filter ((<= natToNum @(topologySize - 1)) . fst) + . Vec.toList + . Vec.zip links process prevDP Capture{..} = - let PlotData{..} = fromHex plotData - captureType = fromHex captureCond + let PlotData{..} = fromHex plotData + captureType = fromHex captureCond - cycleDiff = case captureType of + cycleDiff = case captureType of DataChange -> dpCycleDiff prevDP - _ -> let (toInteger -> pL, toInteger -> cL) = dpGlobalLast prevDP - (toInteger -> pN, toInteger -> cN) = fromHex globalTimestamp - in Femtoseconds $ fromInteger - $ (pN - pL) * natToInteger @(SyncPulseCycles Basic125) - + (cN - cL) - - knownClockDifference = Femtoseconds $ fromIntegral $ (1000 *) - $ snatToInteger (clockPeriod @Basic125) - - snatToInteger (clockPeriod @External) - - - localStamp = + _ -> + let (toInteger -> pL, toInteger -> cL) = dpGlobalLast prevDP + (toInteger -> pN, toInteger -> cN) = fromHex globalTimestamp + in Femtoseconds $ + fromInteger $ + (pN - pL) * natToInteger @(SyncPulseCycles Basic125) + + (cN - cL) + + knownClockDifference = + Femtoseconds $ + fromIntegral $ + (1000 *) $ + snatToInteger (clockPeriod @Basic125) + - snatToInteger (clockPeriod @External) + + localStamp = let ref = "[" <> show sampleInBuffer <> "]" - in case fromHex localTimestamp of - NoReference -> error $ "LT: no reference " <> ref - TooLarge -> error $ "LT: too large " <> ref - Difference x -> x + 1 + in case fromHex localTimestamp of + NoReference -> error $ "LT: no reference " <> ref + TooLarge -> error $ "LT: too large " <> ref + Difference x -> x + 1 - globalTime = globalTsToFs $ fromHex globalTimestamp - localTime = case captureType of + globalTime = globalTsToFs $ fromHex globalTimestamp + localTime = case captureType of UntilTrigger -> globalTime - _ -> dpLocalTime prevDP - + localStamp ~* clockPeriodFs (Proxy @External) - - globalTimeDelta = globalTime - - dpLastScheduledGlobalTime prevDP - localTimeDelta = localTime - - dpLastScheduledLocalTime prevDP - - driftPerCycle = case captureType of + _ -> + dpLocalTime prevDP + + localStamp ~* clockPeriodFs (Proxy @External) + + globalTimeDelta = + globalTime + - dpLastScheduledGlobalTime prevDP + localTimeDelta = + localTime + - dpLastScheduledLocalTime prevDP + + driftPerCycle = case captureType of DataChange -> dpDrift prevDP - _ -> (globalTimeDelta - localTimeDelta) `div` cycleDiff - - knownClockDifference - - ccChanges = dpCCChanges prevDP - + natToNum @AccWindowHeight * sign dSpeedChange - - dataCounts = (\a b -> - ( \(x,_,_) y -> - extend - @_ - @compressedElasticBufferBits - @( decompressedElasticBufferBits - - compressedElasticBufferBits - ) x - + y - ) <$> a - <*> b - ) <$> topologyView dEBData - <*> dpDataCounts prevDP + _ -> + (globalTimeDelta - localTimeDelta) `div` cycleDiff + - knownClockDifference + + ccChanges = + dpCCChanges prevDP + + natToNum @AccWindowHeight * sign dSpeedChange + + dataCounts = + ( \a b -> + ( \(x, _, _) y -> + extend + @_ + @compressedElasticBufferBits + @( decompressedElasticBufferBits + - compressedElasticBufferBits + ) + x + + y + ) + <$> a + <*> b + ) + <$> topologyView dEBData + <*> dpDataCounts prevDP in DataPoint - { dpIndex = sampleInBuffer - , dpGlobalLast = + { dpIndex = sampleInBuffer + , dpGlobalLast = case captureType of DataChange -> dpGlobalLast prevDP - _ -> fromHex globalTimestamp - , dpCycleDiff = cycleDiff - , dpGlobalTime = globalTime + _ -> fromHex globalTimestamp + , dpCycleDiff = cycleDiff + , dpGlobalTime = globalTime , dpLastScheduledGlobalTime = case captureType of DataChange -> dpLastScheduledGlobalTime prevDP - _ -> globalTime - , dpLocalTime = localTime - , dpLastScheduledLocalTime = + _ -> globalTime + , dpLocalTime = localTime + , dpLastScheduledLocalTime = case captureType of DataChange -> dpLastScheduledLocalTime prevDP - _ -> localTime - , dpDrift = driftPerCycle - , dpCCChanges = ccChanges - , dpRfStage = + _ -> localTime + , dpDrift = driftPerCycle + , dpCCChanges = ccChanges + , dpRfStage = case dRfStageChange of - Stable -> dpRfStage prevDP + Stable -> dpRfStage prevDP ToDetect -> RSDetect - ToWait -> RSWait - ToDone -> RSDone - , dpDataCounts = dataCounts - , dpStability = - let combine (Just (_, st, se)) (Just (StabilityIndication{..})) = - Just StabilityIndication - { stable = fromMaybe stable st - , settled = fromMaybe settled se - } + ToWait -> RSWait + ToDone -> RSDone + , dpDataCounts = dataCounts + , dpStability = + let combine (Just (_, st, se)) (Just (StabilityIndication{..})) = + Just + StabilityIndication + { stable = fromMaybe stable st + , settled = fromMaybe settled se + } combine _ _ = Nothing - in Vec.zipWith combine + in Vec.zipWith + combine (topologyView dEBData) (dpStability prevDP) } - initDummy = DataPoint - { dpIndex = -1 - , dpGlobalLast = (0,0) - , dpCycleDiff = 0 - , dpGlobalTime = 0 - , dpLastScheduledGlobalTime = 0 - , dpLocalTime = 0 - , dpLastScheduledLocalTime = 0 - , dpDrift = 0 - , dpCCChanges = 0 - , dpRfStage = RSDetect - , dpDataCounts = topologyView $ Vec.repeat 0 - , dpStability = topologyView $ Vec.repeat StabilityIndication - { stable = False - , settled = False - } - } + initDummy = + DataPoint + { dpIndex = -1 + , dpGlobalLast = (0, 0) + , dpCycleDiff = 0 + , dpGlobalTime = 0 + , dpLastScheduledGlobalTime = 0 + , dpLocalTime = 0 + , dpLastScheduledLocalTime = 0 + , dpDrift = 0 + , dpCCChanges = 0 + , dpRfStage = RSDetect + , dpDataCounts = topologyView $ Vec.repeat 0 + , dpStability = + topologyView $ + Vec.repeat + StabilityIndication + { stable = False + , settled = False + } + } globalTsToFs :: GlobalTimestamp Basic125 -> Femtoseconds globalTsToFs (pulses, cycles) = - (pulses ~* syncPulsePeriodFs) + - (cycles ~* clockPeriodFs (Proxy @Basic125)) + (pulses ~* syncPulsePeriodFs) + + (cycles ~* clockPeriodFs (Proxy @Basic125)) where syncPulsePeriodFs = Femtoseconds $ natToNum @(1000 * SyncPulsePeriod) fromCsvDump :: forall decompressedElasticBufferBits - -- ^ the bitsize of the elastic buffer entries after decompression + -- \^ the bitsize of the elastic buffer entries after decompression topologySize - -- ^ the size of the topology underlying the data to be processed - utilizedFpgaCount - -- ^ the number of hardware nodes used to generated the data - . + -- \^ the size of the topology underlying the data to be processed + utilizedFpgaCount. + -- \^ the number of hardware nodes used to generated the data + ( KnownNat decompressedElasticBufferBits , CompressedBufferSize <= decompressedElasticBufferBits , KnownNat topologySize @@ -431,39 +509,44 @@ fromCsvDump :: (Handle, FilePath) -> ConduitT () Void IO [DataPoint topologySize decompressedElasticBufferBits] fromCsvDump t i links (csvHandle, csvFile) = - -- turn the input file into a conduit source - sourceHandle csvHandle - -- plugin the CSV parser - .| fromNamedCsvStreamError defaultDecodeOptions toIOE - -- drop the first two header lines and ensure that the remaining - -- data entries are valid - .| (dropC 1 >> checkForErrors 0) - -- post process the data - .| postProcess - @topologySize - @decompressedElasticBufferBits - @utilizedFpgaCount - @CompressedBufferSize - t i links - -- return as a list - .| sinkList + -- turn the input file into a conduit source + sourceHandle csvHandle + -- plugin the CSV parser + .| fromNamedCsvStreamError defaultDecodeOptions toIOE + -- drop the first two header lines and ensure that the remaining + -- data entries are valid + .| (dropC 1 >> checkForErrors 0) + -- post process the data + .| postProcess + @topologySize + @decompressedElasticBufferBits + @utilizedFpgaCount + @CompressedBufferSize + t + i + links + -- return as a list + .| sinkList where - toIOE (HaltingCsvParseError _ msg) = IOError - { ioe_handle = Just csvHandle - , ioe_type = SystemError - , ioe_location = csvFile - , ioe_description = Text.unpack msg - , ioe_errno = Nothing - , ioe_filename = Just csvFile - } - - checkForErrors n = await >>= \case - Nothing -> return () - Just (Left e) -> throw $ CsvParseError n e - Just (Right x) -> yield x >> checkForErrors (n + 1) - --- | The HITL tests, whose post proc data offers a simulation config --- for plotting. + toIOE (HaltingCsvParseError _ msg) = + IOError + { ioe_handle = Just csvHandle + , ioe_type = SystemError + , ioe_location = csvFile + , ioe_description = Text.unpack msg + , ioe_errno = Nothing + , ioe_filename = Just csvFile + } + + checkForErrors n = + await >>= \case + Nothing -> return () + Just (Left e) -> throw $ CsvParseError n e + Just (Right x) -> yield x >> checkForErrors (n + 1) + +{- | The HITL tests, whose post proc data offers a simulation config +for plotting. +-} knownTestsWithSimConf :: [(String, [(String, Maybe SimConf)])] knownTestsWithSimConf = hasSimConf <$> hitlTests where @@ -478,89 +561,106 @@ plotTest testDir mCfg dir globalOutDir = do putStrLn $ "Creating plots for test case: " <> testName let - knownId = flip Set.member $ Set.fromList $ Vec.toList - $ Vec.imap (\i a -> show i <> "_" <> fst a) fpgaSetup - topFromDirs = listDirectory dir - >>= filterM (doesDirectoryExist . (dir )) - >>= return . fromJust . someNatVal . toInteger . length . filter knownId - >>= \case - SomeNat n -> return $ STop $ complete $ snatProxy n + knownId = + flip Set.member $ + Set.fromList $ + Vec.toList $ + Vec.imap (\i a -> show i <> "_" <> fst a) fpgaSetup + topFromDirs = + listDirectory dir + >>= filterM (doesDirectoryExist . (dir )) + >>= return . fromJust . someNatVal . toInteger . length . filter knownId + >>= \case + SomeNat n -> return $ STop $ complete $ snatProxy n STop (t :: Topology topologySize) <- case mCfg of - Nothing -> topFromDirs + Nothing -> topFromDirs Just cfg -> case SimConf.mTopologyType cfg of - Nothing -> topFromDirs - Just (Random {}) -> topFromDirs + Nothing -> topFromDirs + Just (Random{}) -> topFromDirs Just (DotFile f) -> readFile f >>= either die return . fromDot - Just tt -> fromTopologyType tt >>= either die return + Just tt -> fromTopologyType tt >>= either die return case TLW.SNat @topologySize %<=? TLW.SNat @FpgaCount of LE Refl -> case TLW.SNat @1 %<=? TLW.SNat @topologySize of LE Refl -> do - let fpgas = Vec.toList $ Vec.imap (,) - $ Vec.take @topologySize @(FpgaCount - topologySize) - SNat fpgaSetup + let fpgas = + Vec.toList $ + Vec.imap (,) $ + Vec.take @topologySize @(FpgaCount - topologySize) + SNat + fpgaSetup postProcessData <- do - forM fpgas $ \(i, (fpgaId, links)) -> concat . filter (not . null) <$> do - let d = dir (show i <> "_" <> fpgaId) - unlessM (doesDirectoryExist d) $ die $ "No directory: " <> d - csvFiles <- checkCsvFilesExist d <$> listDirectory d - forM csvFiles $ \f -> do - h <- openFile f ReadMode - rs <- catch - (do rs <- runConduit $ fromCsvDump @CccBufferSize t i links (h, f) - putStrLn ("Using " <> (takeBaseName d takeFileName f)) - return rs - ) $ \(err :: CsvParseError) -> case err of + forM fpgas $ \(i, (fpgaId, links)) -> + concat . filter (not . null) <$> do + let d = dir (show i <> "_" <> fpgaId) + unlessM (doesDirectoryExist d) $ die $ "No directory: " <> d + csvFiles <- checkCsvFilesExist d <$> listDirectory d + forM csvFiles $ \f -> do + h <- openFile f ReadMode + rs <- catch + ( do + rs <- runConduit $ fromCsvDump @CccBufferSize t i links (h, f) + putStrLn ("Using " <> (takeBaseName d takeFileName f)) + return rs + ) + $ \(err :: CsvParseError) -> case err of -- Ignore additional CSV files that may have -- been produced by other ILAs. They are -- identified via an error while parsing the -- header row. CsvParseError 0 _ -> return [] CsvParseError n (CsvStreamRecordParseError msg) -> - error $ unlines - [ "Error while parsing" - , "" - , " " <> f - , "" - , "Line " <> show (n + 3) <> ", " <> Text.unpack msg + error $ + unlines + [ "Error while parsing" + , "" + , " " <> f + , "" + , "Line " <> show (n + 3) <> ", " <> Text.unpack msg + ] + hClose h + + let + ls = show <$> filter (hasEdge t i) (Vec.toList Vec.indicesI) + header = + Vector.fromList $ + map BSC.pack $ + [ "Index" + , "Synchronized Time (fs)" + , "Local Clock time (fs)" + , "Clock Period Drift (fs)" + , "Integrated FINC/FDECs" + , "Reframing State" ] - hClose h - - let - ls = show <$> filter (hasEdge t i) (Vec.toList Vec.indicesI) - header = Vector.fromList $ map BSC.pack $ - [ "Index" - , "Synchronized Time (fs)" - , "Local Clock time (fs)" - , "Clock Period Drift (fs)" - , "Integrated FINC/FDECs" - , "Reframing State" - ] - <> (("EB " <>) <$> ls) - <> ((<> " is stable") <$> ls) - <> ((<> " is settled") <$> ls) - - unless (null rs) $ do - createDirectoryIfMissing True outDir - BSL.writeFile (outDir (takeFileName d <> ".csv")) - $ encodeByName header rs - - return (toPlotData <$> rs) + <> (("EB " <>) <$> ls) + <> ((<> " is stable") <$> ls) + <> ((<> " is settled") <$> ls) + + unless (null rs) $ do + createDirectoryIfMissing True outDir + BSL.writeFile (outDir (takeFileName d <> ".csv")) $ + encodeByName header rs + + return (toPlotData <$> rs) createDirectoryIfMissing True outDir plot outDir t $ Vec.unsafeFromList postProcessData - let allStable = all ((\(_,_,_,xs) -> all (stable . snd) xs) . last) - postProcessData + let allStable = + all + ((\(_, _, _, xs) -> all (stable . snd) xs) . last) + postProcessData case mCfg of Nothing -> return () Just cfg' -> do - let cfg = cfg' { SimConf.outDir = outDir - , SimConf.stable = Just allStable - } + let cfg = + cfg' + { SimConf.outDir = outDir + , SimConf.stable = Just allStable + } ids = bimap toInteger fst <$> fpgas case SimConf.mTopologyType cfg of Nothing -> writeTop Nothing @@ -578,15 +678,16 @@ plotTest testDir mCfg dir globalOutDir = do checkCsvFilesExist d xs = let ys = filter ((== ".csv") . takeExtensions) $ fmap (d ) xs in case ys of - [] -> error $ d <> " does not contain any *.csv files. Aborting." - _ -> ys + [] -> error $ d <> " does not contain any *.csv files. Aborting." + _ -> ys toPlotData DataPoint{..} = ( dpGlobalTime , dpDrift , dpRfStage - , mapMaybe (uncurry $ liftA2 (,)) - $ Vec.toList $ Vec.zip dpDataCounts dpStability + , mapMaybe (uncurry $ liftA2 (,)) $ + Vec.toList $ + Vec.zip dpDataCounts dpStability ) writeTop (fromMaybe "digraph{}" -> str) = @@ -597,61 +698,71 @@ plotTest testDir mCfg dir globalOutDir = do hClose h main :: IO () -main = getArgs >>= \case - [] -> wrongNumberOfArguments - plotDataSource : xr -> do - (plotDataDir, outDir, mArtifactName) <- do - isDir <- doesDirectoryExist plotDataSource - (plotDataDir, yr, mA) <- - if isDir - then return (plotDataSource, xr, Nothing) - else case isRunArtifactReference plotDataSource of - Nothing -> die $ "Invalid argument: " <> plotDataSource - Just (runId, artifactName) -> case xr of - [] -> wrongNumberOfArguments - dir : yr -> - let fullArtifactName = "_build-" <> artifactName <> "-debug" - in retrieveArtifact runId fullArtifactName dir >>= \case - Just err -> die $ unlines - [ "Cannot retrieve artifact." - , show err - ] - Nothing -> return (dir, yr, Just artifactName) - let (outDir, zr) = fromMaybe (".", []) $ uncons yr - unless (null zr) wrongNumberOfArguments - return (plotDataDir, outDir, mA) - - tests <- do - dirs <- listDirectory plotDataDir - let hitlDir = plotDataDir "hitl" - files <- bool - (die $ "No 'hitl' folder in " <> fromMaybe plotDataDir mArtifactName) - (listDirectory hitlDir) - ("hitl" `elem` dirs) - case filter (".yml" `isExtensionOf`) files of - [] -> die $ "No YAML files in " <> hitlDir - [x] -> return $ getTestsWithSimConf $ takeBaseName x - _ -> die $ "Too many YAML files in " <> hitlDir - - (testDirs, testsDir) <- do - let epsfix = maybe (Left "Bittide.Instances.Hitl.") Right mArtifactName - dir <- diveDownInto epsfix plotDataDir - listDirectory dir >>= filterM (doesDirectoryExist . (dir )) - <&> (, dir) - - let sDirs = Set.fromList testDirs - sNames = Set.fromList $ fst <$> tests - when (sDirs /= sNames) $ die $ - if sDirs `Set.isProperSubsetOf` sNames - then "Missing tests " - <> show (Set.toList (sNames `Set.difference` sDirs)) - <> " in " <> testsDir - else "Unknown tests " - <> show (Set.toList (sDirs `Set.difference` sNames)) - <> " in " <> testsDir - - forM_ tests $ \(test, cfg) -> - plotTest test cfg (testsDir test) outDir +main = + getArgs >>= \case + [] -> wrongNumberOfArguments + plotDataSource : xr -> do + (plotDataDir, outDir, mArtifactName) <- do + isDir <- doesDirectoryExist plotDataSource + (plotDataDir, yr, mA) <- + if isDir + then return (plotDataSource, xr, Nothing) + else case isRunArtifactReference plotDataSource of + Nothing -> die $ "Invalid argument: " <> plotDataSource + Just (runId, artifactName) -> case xr of + [] -> wrongNumberOfArguments + dir : yr -> + let fullArtifactName = "_build-" <> artifactName <> "-debug" + in retrieveArtifact runId fullArtifactName dir >>= \case + Just err -> + die $ + unlines + [ "Cannot retrieve artifact." + , show err + ] + Nothing -> return (dir, yr, Just artifactName) + let (outDir, zr) = fromMaybe (".", []) $ uncons yr + unless (null zr) wrongNumberOfArguments + return (plotDataDir, outDir, mA) + + tests <- do + dirs <- listDirectory plotDataDir + let hitlDir = plotDataDir "hitl" + files <- + bool + (die $ "No 'hitl' folder in " <> fromMaybe plotDataDir mArtifactName) + (listDirectory hitlDir) + ("hitl" `elem` dirs) + case filter (".yml" `isExtensionOf`) files of + [] -> die $ "No YAML files in " <> hitlDir + [x] -> return $ getTestsWithSimConf $ takeBaseName x + _ -> die $ "Too many YAML files in " <> hitlDir + + (testDirs, testsDir) <- do + let epsfix = maybe (Left "Bittide.Instances.Hitl.") Right mArtifactName + dir <- diveDownInto epsfix plotDataDir + listDirectory dir + >>= filterM (doesDirectoryExist . (dir )) + <&> (,dir) + + let sDirs = Set.fromList testDirs + sNames = Set.fromList $ fst <$> tests + when (sDirs /= sNames) $ + die $ + if sDirs `Set.isProperSubsetOf` sNames + then + "Missing tests " + <> show (Set.toList (sNames `Set.difference` sDirs)) + <> " in " + <> testsDir + else + "Unknown tests " + <> show (Set.toList (sDirs `Set.difference` sNames)) + <> " in " + <> testsDir + + forM_ tests $ \(test, cfg) -> + plotTest test cfg (testsDir test) outDir where getTestsWithSimConf name = maybe [] snd $ find ((== name) . fst) knownTestsWithSimConf @@ -661,23 +772,28 @@ main = getArgs >>= \case >>= filterM doesDirectoryExist . fmap (dir ) >>= \case [] -> die $ "Empty directory: " <> dir - dirs -> let subDirs = takeFileName <$> dirs in if - | "vivado" `elem` subDirs -> - diveDownInto epsfix $ dir "vivado" - | "ila-data" `elem` subDirs -> - diveDownInto epsfix $ dir "ila-data" - | otherwise -> - case filter (either isPrefixOf isSuffixOf epsfix) subDirs of - subDir : _ -> diveDownInto epsfix $ dir subDir - _ -> return dir + dirs -> + let subDirs = takeFileName <$> dirs + in if + | "vivado" `elem` subDirs -> + diveDownInto epsfix $ dir "vivado" + | "ila-data" `elem` subDirs -> + diveDownInto epsfix $ dir "ila-data" + | otherwise -> + case filter (either isPrefixOf isSuffixOf epsfix) subDirs of + subDir : _ -> diveDownInto epsfix $ dir subDir + _ -> return dir isRunArtifactReference arg = case span (/= ':') arg of - (xs, ':':ys) + (xs, ':' : ys) | all isDigit xs && ':' `notElem` ys -> Just (xs, ys) | otherwise -> Nothing _ -> Nothing wrongNumberOfArguments = do name <- getProgName - die $ "Wrong number of arguments. Aborting.\n\n" - <> "Usage: " <> name <> " []" + die $ + "Wrong number of arguments. Aborting.\n\n" + <> "Usage: " + <> name + <> " []" diff --git a/bittide-tools/clockcontrol/sim/src/Domain.hs b/bittide-tools/clockcontrol/sim/src/Domain.hs index 4d4a8a269..db95f3225 100644 --- a/bittide-tools/clockcontrol/sim/src/Domain.hs +++ b/bittide-tools/clockcontrol/sim/src/Domain.hs @@ -1,15 +1,15 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# OPTIONS_GHC -fno-warn-orphans #-} module Domain where import Clash.Explicit.Prelude -createDomain vSystem{ - vName="Bittide" - , vPeriod=hzToPeriod 200e6 - , vResetKind=Synchronous - } +createDomain + vSystem + { vName = "Bittide" + , vPeriod = hzToPeriod 200e6 + , vResetKind = Synchronous + } diff --git a/bittide-tools/clockcontrol/sim/src/Main.hs b/bittide-tools/clockcontrol/sim/src/Main.hs index bd56fb85f..b9b027eb9 100644 --- a/bittide-tools/clockcontrol/sim/src/Main.hs +++ b/bittide-tools/clockcontrol/sim/src/Main.hs @@ -1,12 +1,12 @@ +{-# LANGUAGE ImplicitParams #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RecordWildCards #-} + module Main (main) where import Domain @@ -20,65 +20,78 @@ import Control.Monad (when) import Data.Aeson (decode) import Data.ByteString.Lazy qualified as BS import Data.Maybe (isJust) -import Data.Proxy (Proxy(..)) +import Data.Proxy (Proxy (..)) import Options.Applicative -import System.Exit (exitSuccess, die) +import System.Exit (die, exitSuccess) main :: IO () main = do simCfg@SimConf{..} <- do cfg@SimConf{..} <- execParser cliParser case jsonArgs of - Nothing -> return cfg + Nothing -> return cfg Just file -> do cnt <- BS.readFile file case decode cnt of Nothing -> die $ "ERROR: Invalid JSON file - " <> file - Just o -> return o { jsonArgs } + Just o -> return o{jsonArgs} when createReport $ checkDependencies >>= maybe (return ()) die - sccc <- someCCC (Proxy @Bittide) reframe rusty waitTime - (toInteger stabilityMargin) (toInteger stabilityFrameSize) + sccc <- + someCCC + (Proxy @Bittide) + reframe + rusty + waitTime + (toInteger stabilityMargin) + (toInteger stabilityFrameSize) isStable <- case mTopologyType of Nothing -> - handleParseResult $ Failure - $ parserFailure defaultPrefs cliParser (ShowHelpText Nothing) [] - Just tt -> fromTopologyType tt >>= \case - Left err -> die $ "Error : " <> err - Right t -> simPlot t SimPlotSettings - { plotSamples = samples - , periodsize = duration `quot` samples - , mode = outMode - , dir = outDir - , stopStable = - if stopWhenStable - then Just 0 - else (`quot` samples) <$> stopAfterStable - , fixClockOffs = clockOffsets - , fixStartDelays = startupDelays - , maxStartDelay = maxStartupDelay - , save = \clockOffs startDelays isStable -> do - let cfg = simCfg { stable = isStable - , clockOffsets = clockOffs - , startupDelays = startDelays - } - saveSimConfig t cfg - when (isJust isStable && createReport) $ - checkIntermediateResults outDir - >>= maybe (generateReport "Simulation Report" outDir [] cfg) die - , .. - } + handleParseResult $ + Failure $ + parserFailure defaultPrefs cliParser (ShowHelpText Nothing) [] + Just tt -> + fromTopologyType tt >>= \case + Left err -> die $ "Error : " <> err + Right t -> + simPlot + t + SimPlotSettings + { plotSamples = samples + , periodsize = duration `quot` samples + , mode = outMode + , dir = outDir + , stopStable = + if stopWhenStable + then Just 0 + else (`quot` samples) <$> stopAfterStable + , fixClockOffs = clockOffsets + , fixStartDelays = startupDelays + , maxStartDelay = maxStartupDelay + , save = \clockOffs startDelays isStable -> do + let cfg = + simCfg + { stable = isStable + , clockOffsets = clockOffs + , startupDelays = startDelays + } + saveSimConfig t cfg + when (isJust isStable && createReport) $ + checkIntermediateResults outDir + >>= maybe (generateReport "Simulation Report" outDir [] cfg) die + , .. + } if isStable - then exitSuccess - else die "Simulated topology did not stabilize in time." - + then exitSuccess + else die "Simulated topology did not stabilize in time." where - cliParser = info (simConfigCLIParser <**> helper) - $ fullDesc <> header "Bittide Hardware Topology Simulator" + cliParser = + info (simConfigCLIParser <**> helper) $ + fullDesc <> header "Bittide Hardware Topology Simulator" diff --git a/bittide-tools/hitl/config-gen/Main.hs b/bittide-tools/hitl/config-gen/Main.hs index 66ec09bcf..0bc727a59 100644 --- a/bittide-tools/hitl/config-gen/Main.hs +++ b/bittide-tools/hitl/config-gen/Main.hs @@ -1,19 +1,19 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PackageImports #-} --- | Program that writes YAML configuration files to '_build/hitl', to be used --- by the TCL using Vivado to run hardware-in-the-loop tests. --- --- By default, it writes all known files. If given an identifier, it will only --- write that one. +{- | Program that writes YAML configuration files to '_build/hitl', to be used +by the TCL using Vivado to run hardware-in-the-loop tests. + +By default, it writes all known files. If given an identifier, it will only +write that one. +-} module Main where -import Prelude import Clash.Prelude (BitPack) +import Prelude import Control.Monad (forM, forM_, when) import Data.Aeson (ToJSON) @@ -26,9 +26,9 @@ import System.FilePath (()) import System.IO (hPutStrLn, stderr) import Bittide.Hitl (HitlTestsWithPostProcData, packAndEncode) -import Bittide.Instances.Hitl.Tests (HitlTest(..), hitlTests) +import Bittide.Instances.Hitl.Tests (HitlTest (..), hitlTests) -import qualified Data.ByteString.Lazy.Char8 as LazyByteString +import Data.ByteString.Lazy.Char8 qualified as LazyByteString data Config = Config { name :: String @@ -38,16 +38,16 @@ data Config = Config -- | Known configurations that can be written to @_build/hitl@ configs :: IO [Config] configs = forM hitlTests $ \case - KnownType nm config -> pure $ makeConfig nm config + KnownType nm config -> pure $ makeConfig nm config LoadConfig nm fileName -> loadConfig nm fileName -- | First argument on command line, as Haskell type data Arg = Write - { -- | Fully qualified name of HITL YAML to render. If 'Nothing', render all + { fqn :: Maybe String + -- ^ Fully qualified name of HITL YAML to render. If 'Nothing', render all -- known identifiers - fqn :: Maybe String - } + } | List -- | Be verbose to stderr? @@ -64,28 +64,29 @@ argParser = (,) <$> verbose <*> arg command "write" (info writeConfigsParser (progDesc "Write all known configs to _build/hitl")) - <> command - "list" - (info (pure List) (progDesc "List all known configs stdout")) + <> command + "list" + (info (pure List) (progDesc "List all known configs stdout")) -- | Parser for the write command, now expecting an optional identifier writeConfigsParser :: Parser Arg writeConfigsParser = - fmap Write - $ optional - $ strArgument - $ metavar "FULLY_QUALIFIED_NAME" - <> help "For example, 'Bittide.Instances.Hitl.FincFdec.fincFdecTests'" + fmap Write $ + optional $ + strArgument $ + metavar "FULLY_QUALIFIED_NAME" + <> help "For example, 'Bittide.Instances.Hitl.FincFdec.fincFdecTests'" -- | Load config from an existing YAML file in 'data/test_configs' loadConfig :: String -> FilePath -> IO Config loadConfig nm fileName = do fullPath <- getDataFileName ("data" "test_configs" fileName) yamlContents <- LazyByteString.readFile fullPath - pure $ Config - { name = nm - , yaml = yamlContents - } + pure $ + Config + { name = nm + , yaml = yamlContents + } -- | Create config from a known HITL test. makeConfig :: @@ -122,21 +123,20 @@ main = do case matchedConfig of [] -> die $ "No config found for '" <> fqn <> "'. Available: \n\n" <> names - (_:_:_) -> die $ "Multiple configs matched '" <> fqn <> "'" + (_ : _ : _) -> die $ "Multiple configs matched '" <> fqn <> "'" [Config{name, yaml}] -> do let path = buildDir name <> ".yml" when verbose $ hPutStrLn stderr $ "Writing " <> path <> ".." LazyByteString.writeFile path yaml - (_verbose, List) -> do forM_ configs1 $ \Config{name} -> putStrLn name - where - parserPrefs = prefs $ - showHelpOnError - <> showHelpOnEmpty - <> noBacktrack + parserPrefs = + prefs $ + showHelpOnError + <> showHelpOnEmpty + <> noBacktrack opts = info diff --git a/bittide-tools/program/stream/Main.hs b/bittide-tools/program/stream/Main.hs index aa8055a19..bb505ec55 100644 --- a/bittide-tools/program/stream/Main.hs +++ b/bittide-tools/program/stream/Main.hs @@ -6,8 +6,8 @@ import Prelude import Bittide.ProcessingElement.ProgramStream -import qualified Data.ByteString as BS -import qualified Clash.Prelude as C +import Clash.Prelude qualified as C +import Data.ByteString qualified as BS import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) diff --git a/bittide/src/Bittide/Arithmetic/Ppm.hs b/bittide/src/Bittide/Arithmetic/Ppm.hs index 9321811e8..7b1c94324 100644 --- a/bittide/src/Bittide/Arithmetic/Ppm.hs +++ b/bittide/src/Bittide/Arithmetic/Ppm.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NumericUnderscores #-} @@ -9,11 +8,11 @@ module Bittide.Arithmetic.Ppm where import Clash.Explicit.Prelude -import Clash.Signal.Internal (Femtoseconds (Femtoseconds), hzToFs, fsToHz) +import Clash.Signal.Internal (Femtoseconds (Femtoseconds), fsToHz, hzToFs) +import qualified Control.Exception as E (assert) import Data.Int (Int64) import Data.Ratio -import qualified Control.Exception as E (assert) import GHC.Stack (HasCallStack) import System.Random (Random) @@ -24,24 +23,24 @@ newtype Ppm = Ppm Int64 type Hz = Ratio Natural -- PPM arithmetic on Hz -diffHz :: HasCallStack => Ppm -> Hz -> Hz +diffHz :: (HasCallStack) => Ppm -> Hz -> Hz diffHz (Ppm ppm) hz - | ppm < 0 = error $ "diffHz: ppm must be absolute, not" <> show ppm + | ppm < 0 = error $ "diffHz: ppm must be absolute, not" <> show ppm | otherwise = hz / (1e6 / (fromIntegral ppm % 1)) -speedUpHz :: HasCallStack => Ppm -> Hz -> Hz +speedUpHz :: (HasCallStack) => Ppm -> Hz -> Hz speedUpHz ppm hz = hz + diffHz ppm hz -slowDownHz :: HasCallStack => Ppm -> Hz -> Hz +slowDownHz :: (HasCallStack) => Ppm -> Hz -> Hz slowDownHz ppm hz = hz - diffHz ppm hz -- PPM arithmetic on periods -diffPeriod :: HasCallStack => Ppm -> Femtoseconds -> Femtoseconds +diffPeriod :: (HasCallStack) => Ppm -> Femtoseconds -> Femtoseconds diffPeriod (Ppm ppm) (Femtoseconds fs) = E.assert (ppm /= 0) $ Femtoseconds absFs where absFs = fs `div` (1_000_000 `div` ppm) -adjustPeriod :: HasCallStack => Ppm -> Femtoseconds -> Femtoseconds +adjustPeriod :: (HasCallStack) => Ppm -> Femtoseconds -> Femtoseconds adjustPeriod (Ppm ppm) fs = case compare ppm 0 of LT -> hzToFs (slowDownHz (Ppm (abs ppm)) (fsToHz fs)) diff --git a/bittide/src/Bittide/Arithmetic/Time.hs b/bittide/src/Bittide/Arithmetic/Time.hs index e272f8551..182ddee54 100644 --- a/bittide/src/Bittide/Arithmetic/Time.hs +++ b/bittide/src/Bittide/Arithmetic/Time.hs @@ -1,29 +1,39 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE FlexibleInstances,MultiParamTypeClasses,TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NumericUnderscores #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Bittide.Arithmetic.Time where +import Clash.Explicit.Prelude hiding (PeriodToCycles, natVal) import GHC.Stack (HasCallStack) -import Clash.Explicit.Prelude hiding (natVal, PeriodToCycles) -import Clash.Class.Counter (countSucc, Counter) +import Clash.Class.Counter (Counter, countSucc) import Clash.Signal.Internal (Femtoseconds (Femtoseconds), mapFemtoseconds) -import Data.Data (Proxy(..)) +import Data.Data (Proxy (..)) import Data.Int (Int64) import Data.Kind (Type) +import GHC.TypeLits.KnownNat (KnownNat1 (..), SNatKn (..), nameToSymbol) import GHC.TypeNats (natVal) -import GHC.TypeLits.KnownNat (KnownNat1 (..),SNatKn(..), nameToSymbol) --- | XXX: We currently retain this in favor of @clash-prelude@s 'PeriodToCycles' --- until @1 <= DomainPeriod dom@ is trivially true. Related issue: --- https://github.com/clash-lang/ghc-typelits-extra/issues/56 --- ---Number of clock cycles required at the clock frequency of @dom@ before a minimum @period@ has passed. --- Is always at least one. +{- | XXX: We currently retain this in favor of @clash-prelude@s 'PeriodToCycles' +until @1 <= DomainPeriod dom@ is trivially true. Related issue: +https://github.com/clash-lang/ghc-typelits-extra/issues/56 + +Number of clock cycles required at the clock frequency of @dom@ before a minimum @period@ has passed. +Is always at least one. +-} type PeriodToCycles dom period = Max 1 (DivRU period (Max 1 (DomainPeriod dom))) -- Make ghc-typelits-knownnat look through time related type aliases. @@ -48,8 +58,9 @@ instance (KnownNat ps) => KnownNat1 $(nameToSymbol ''Seconds) ps where natSing1 = SNatKn (natVal (Proxy @(1_000_000_000_000 * ps))) {-# NOINLINE natSing1 #-} --- | 'Index' with its 'maxBound' corresponding to the number of cycles needed to --- wait for /n/ milliseconds. +{- | 'Index' with its 'maxBound' corresponding to the number of cycles needed to +wait for /n/ milliseconds. +-} type IndexMs dom n = Index (PeriodToCycles dom (Milliseconds n)) seconds :: Int64 -> Femtoseconds @@ -75,56 +86,74 @@ femtoseconds :: Int64 -> Femtoseconds femtoseconds = Femtoseconds {-# INLINE femtoseconds #-} --- | Rises after the incoming signal has been 'True' for the specified amount of --- time. Use this function if you know the time to wait for at compile time. If --- not, use 'trueForSteps'. +{- | Rises after the incoming signal has been 'True' for the specified amount of +time. Use this function if you know the time to wait for at compile time. If +not, use 'trueForSteps'. +-} trueFor :: - forall dom t. HasCallStack => + forall dom t. + (HasCallStack) => (KnownDomain dom, KnownNat t) => - SNat t -> - -- ^ Use the type aliases of 'Bittide.Arithmetic.Time' for time span + -- | Use the type aliases of 'Bittide.Arithmetic.Time' for time span -- specification. + SNat t -> Clock dom -> Reset dom -> Signal dom Bool -> Signal dom Bool trueFor _ clk rst = - moore clk rst enableGen transF (== maxBound) + moore + clk + rst + enableGen + transF + (== maxBound) (0 :: Index (PeriodToCycles dom t)) where transF counter = \case True -> satSucc SatBound counter - _ -> 0 + _ -> 0 --- | Rises after the incoming signal has been 'True' for the specified amount of --- time given as a configurable number of steps of a given step size (i.e., wait --- for @stepSize * numberOfSteps@)). Example invocation: --- --- > trueForSteps @(Milliseconds 1) Proxy someLimit clk rst signal --- --- which will wait for @someLimit@ milliseconds. Use 'trueFor' if you know the --- time to wait for at compile time. If not, use 'trueForSteps'. +{- | Rises after the incoming signal has been 'True' for the specified amount of +time given as a configurable number of steps of a given step size (i.e., wait +for @stepSize * numberOfSteps@)). Example invocation: + +> trueForSteps @(Milliseconds 1) Proxy someLimit clk rst signal + +which will wait for @someLimit@ milliseconds. Use 'trueFor' if you know the +time to wait for at compile time. If not, use 'trueForSteps'. +-} trueForSteps :: - forall (stepSize :: Nat) (dom :: Domain) (counter :: Type) . + forall (stepSize :: Nat) (dom :: Domain) (counter :: Type). ( HasCallStack , KnownDomain dom , KnownNat stepSize - , NFDataX counter, Bounded counter, Counter counter, Eq counter, Num counter + , NFDataX counter + , Bounded counter + , Counter counter + , Eq counter + , Num counter ) => - Proxy stepSize -> - -- ^ Step size. Use the type aliases of 'Bittide.Arithmetic.Time' for time span + -- | Step size. Use the type aliases of 'Bittide.Arithmetic.Time' for time span -- specification. + Proxy stepSize -> + -- | Number of steps to wait for counter -> - -- ^ Number of steps to wait for Clock dom -> Reset dom -> Signal dom Bool -> Signal dom Bool trueForSteps _ limit clk rst = - moore clk rst enableGen transF ((== limit) . fst) (0, 0 :: Index (PeriodToCycles dom stepSize)) + moore + clk + rst + enableGen + transF + ((== limit) . fst) + (0, 0 :: Index (PeriodToCycles dom stepSize)) where transF cntr@(ms, _) = \case True | ms == limit -> cntr - | otherwise -> countSucc cntr - _ -> minBound + | otherwise -> countSucc cntr + _ -> minBound diff --git a/bittide/src/Bittide/Axi4.hs b/bittide/src/Bittide/Axi4.hs index e1b8bfc6f..ebcc0f8a4 100644 --- a/bittide/src/Bittide/Axi4.hs +++ b/bittide/src/Bittide/Axi4.hs @@ -1,18 +1,15 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MagicHash #-} - {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} {-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} -module Bittide.Axi4 -( +module Bittide.Axi4 ( -- * Scaling circuits axiStreamFromByteStream, axiStreamToByteStream, @@ -37,7 +34,7 @@ module Bittide.Axi4 isPackedTransfer, -- * Internal - mkKeep + mkKeep, ) where import Clash.Prelude @@ -53,48 +50,54 @@ import Data.Maybe import Data.Proxy import Protocols import Protocols.Axi4.Stream as AS -import Protocols.Wishbone as WB import qualified Protocols.DfConv as DfConv +import Protocols.Wishbone as WB {- $setup >>> import Clash.Prelude >>> import Protocols.Axi4.Stream -} --- | An 'Axi4Stream' without gaps in the data. This means that for each transfer --- the following holds: --- --- * For a transfer with _tlast deasserted, all _tkeep bools are set. --- * For a transfer with _tlast asserted, the first /n/ bools of _tkeep are set, --- where n is the number of bytes in the transfer. +{- | An 'Axi4Stream' without gaps in the data. This means that for each transfer +the following holds: + +* For a transfer with _tlast deasserted, all _tkeep bools are set. +* For a transfer with _tlast asserted, the first /n/ bools of _tkeep are set, + where n is the number of bytes in the transfer. +-} type PackedAxi4Stream dom conf userType = Axi4Stream dom conf userType {-# NOINLINE axiStreamFromByteStream #-} --- | Transforms an 'Axi4Stream' of 1 byte wide into an 'Axi4Stream' of /n/ bytes --- wide. If it encounters '_tlast' or has captured /n/ bytes, it will present --- the transfer at the output. Note that if less than /n/ bytes have been --- captured, but '_tlast' is set, the component will output the captured bytes --- with appropriately set '_tkeep' bits. The '_tuser', _tdest' and '_tid' signals --- are blindly routed to the output. This effectively means that all but the --- last '_tuser', '_tdest', '_tid' are linked to a valid transfer. --- --- TODO: Add test that verifies throughput requirements. --- TODO: Make user specify the number of bytes to capture, instead of number of --- bytes minus one (@addedWidth@). + +{- | Transforms an 'Axi4Stream' of 1 byte wide into an 'Axi4Stream' of /n/ bytes +wide. If it encounters '_tlast' or has captured /n/ bytes, it will present +the transfer at the output. Note that if less than /n/ bytes have been +captured, but '_tlast' is set, the component will output the captured bytes +with appropriately set '_tkeep' bits. The '_tuser', _tdest' and '_tid' signals +are blindly routed to the output. This effectively means that all but the +last '_tuser', '_tdest', '_tid' are linked to a valid transfer. + +TODO: Add test that verifies throughput requirements. +TODO: Make user specify the number of bytes to capture, instead of number of + bytes minus one (@addedWidth@). +-} axiStreamFromByteStream :: - forall dom addedWidth idWidth destWidth userType . + forall dom addedWidth idWidth destWidth userType. ( HiddenClockResetEnable dom , KnownNat addedWidth , KnownNat idWidth , KnownNat destWidth , Eq userType , NFDataX userType - , Show userType) => + , Show userType + ) => Circuit (Axi4Stream dom ('Axi4StreamConfig 1 idWidth destWidth) userType) - (PackedAxi4Stream dom - ('Axi4StreamConfig (addedWidth + 1) idWidth destWidth) - (Vec (addedWidth + 1) userType)) + ( PackedAxi4Stream + dom + ('Axi4StreamConfig (addedWidth + 1) idWidth destWidth) + (Vec (addedWidth + 1) userType) + ) axiStreamFromByteStream = AS.forceResetSanity |> Circuit (mealyB go Nothing) where go axiStored ~(input, Axi4StreamS2M{_tready = outputReady}) = @@ -110,8 +113,10 @@ axiStreamFromByteStream = AS.forceResetSanity |> Circuit (mealyB go Nothing) -- If the head of the pre-shifted axi has its keep bit set, shifting is done. extendedAxi = fmap (axiUserMap (:< undefUser) . extendAxi @_ @1) axiStored axiPreShift = combinedAxi <|> extendedAxi - axiPostShift = snd $ splitAxi4Stream @1 $ - fmap (axiUserMap (\ v -> (head v, tail v))) axiPreShift + axiPostShift = + snd + $ splitAxi4Stream @1 + $ fmap (axiUserMap (\v -> (head v, tail v))) axiPreShift -- Output the pre-shifted axi if we can not shift anymore. shiftingDone = not dropInput && maybe False isPackedTransfer axiPreShift @@ -120,27 +125,30 @@ axiStreamFromByteStream = AS.forceResetSanity |> Circuit (mealyB go Nothing) -- Flow control (axiNext, inputReady) - | dropInput = (axiStored, True) -- Drop the input - | shiftingDone && outputReady = (Nothing, isJust combinedAxi) -- valid output, accepted - | shiftingDone && not outputReady = (axiStored, False) -- valid output, not accepted - | not shiftingDone && isJust input = (axiPostShift, isJust combinedAxi) -- Shift when input - | not shiftingDone && capturedLast = (axiPostShift, False) -- Shift when captured _tlast - | otherwise = (axiStored, False) -- No input + | dropInput = (axiStored, True) -- Drop the input + | shiftingDone && outputReady = (Nothing, isJust combinedAxi) -- valid output, accepted + | shiftingDone && not outputReady = (axiStored, False) -- valid output, not accepted + | not shiftingDone && isJust input = (axiPostShift, isJust combinedAxi) -- Shift when input + | not shiftingDone && capturedLast = (axiPostShift, False) -- Shift when captured _tlast + | otherwise = (axiStored, False) -- No input -- TODO: Add test that verifies throughput requirements. --- | Transforms an Axi4 stream of /n/ bytes wide into an Axi4 stream of 1 byte --- wide. It stores the incoming transfer and shifts it out one by one. The incoming --- transfer is acknowledged when the last byte is acknowledged by the outgoing transfer. --- The '_tuser', '_tdest' and '_tid' are blindly routed to the output. + +{- | Transforms an Axi4 stream of /n/ bytes wide into an Axi4 stream of 1 byte +wide. It stores the incoming transfer and shifts it out one by one. The incoming +transfer is acknowledged when the last byte is acknowledged by the outgoing transfer. +The '_tuser', '_tdest' and '_tid' are blindly routed to the output. +-} axiStreamToByteStream :: - forall dom dataWidth idWidth destWidth userType . + forall dom dataWidth idWidth destWidth userType. ( HiddenClockResetEnable dom , KnownNat dataWidth , KnownNat idWidth , KnownNat destWidth , Eq userType , NFDataX userType - , Show userType) => + , Show userType + ) => Circuit (PackedAxi4Stream dom ('Axi4StreamConfig dataWidth idWidth destWidth) userType) (Axi4Stream dom ('Axi4StreamConfig 1 idWidth destWidth) userType) @@ -164,35 +172,43 @@ data WbAxisRxBufferState bufferDepth wbBytes = WbAxisRxBufferState , packetComplete :: Bool , bufferFull :: Bool , abortPacket :: Bool - } deriving (Generic, NFDataX, Show) + } + deriving (Generic, NFDataX, Show) {-# NOINLINE wbAxisRxBuffer #-} -- TODO: Replace with PacketStream --- | A wishbone accessible buffer of configurable depth that can store a single Axi4Stream packet. --- The wishbone interface offers access to the buffer and exposes a status register that indicates: --- * If the buffer contains a packet --- * If the buffer is full before, but does not contain a whole packet. --- --- The wishbone addressing must be 4 byte aligned and is as follows: --- * 0 .. 4 * (fifoDepth - 1) = Read-only access into the buffer. --- * 4 * fifoDepth = Byte count register. --- * 4 * (fifoDepth + 1) = Status register --- --- After reading a packet, the byte count must be set to 0 and the status register must be --- cleared. The incoming Axi4Stream interface contains a side channel that can be used to abort --- the incoming packet. If a packet is aborted, the buffer will consume the remaining transfers --- until the end of the packet is reached, after which it will reset the buffer to its initial state. + +{- | A wishbone accessible buffer of configurable depth that can store a single Axi4Stream packet. +The wishbone interface offers access to the buffer and exposes a status register that indicates: + * If the buffer contains a packet + * If the buffer is full before, but does not contain a whole packet. + +The wishbone addressing must be 4 byte aligned and is as follows: + * 0 .. 4 * (fifoDepth - 1) = Read-only access into the buffer. + * 4 * fifoDepth = Byte count register. + * 4 * (fifoDepth + 1) = Status register + +After reading a packet, the byte count must be set to 0 and the status register must be +cleared. The incoming Axi4Stream interface contains a side channel that can be used to abort +the incoming packet. If a packet is aborted, the buffer will consume the remaining transfers +until the end of the packet is reached, after which it will reset the buffer to its initial state. +-} wbAxisRxBufferCircuit :: - forall dom wbAddrW wbBytes bufferBytes . + forall dom wbAddrW wbBytes bufferBytes. ( HiddenClockResetEnable dom - , KnownNat wbAddrW, 2 <= wbAddrW - , KnownNat wbBytes, 1 <= wbBytes - , 1 <= bufferBytes) => + , KnownNat wbAddrW + , 2 <= wbAddrW + , KnownNat wbBytes + , 1 <= wbBytes + , 1 <= bufferBytes + ) => -- | Number of bytes that can be stored in the buffer. SNat bufferBytes -> Circuit - (Wishbone dom 'Standard wbAddrW (Bytes wbBytes), Axi4Stream dom ('Axi4StreamConfig wbBytes 0 0) Bool) + ( Wishbone dom 'Standard wbAddrW (Bytes wbBytes) + , Axi4Stream dom ('Axi4StreamConfig wbBytes 0 0) Bool + ) (CSignal dom (EndOfPacket, BufferFull)) wbAxisRxBufferCircuit bytes = circuit $ \(wb0, axi0) -> do @@ -201,16 +217,19 @@ wbAxisRxBufferCircuit bytes = circ0 -< (wb1, axi1) where circ0 = case cancelMulDiv @wbBytes @8 of - Dict -> Circuit $ \((wbM2S, axiM2S),_) -> do - let (wbS2M, axiS2M,status) = wbAxisRxBuffer bytes wbM2S axiM2S - in ((wbS2M, axiS2M), status) + Dict -> Circuit $ \((wbM2S, axiM2S), _) -> do + let (wbS2M, axiS2M, status) = wbAxisRxBuffer bytes wbM2S axiM2S + in ((wbS2M, axiS2M), status) wbAxisRxBuffer :: - forall dom wbAddrW wbBytes bufferBytes . + forall dom wbAddrW wbBytes bufferBytes. ( HiddenClockResetEnable dom - , KnownNat wbAddrW, 2 <= wbAddrW - , KnownNat wbBytes, 1 <= wbBytes - , 1 <= bufferBytes) => + , KnownNat wbAddrW + , 2 <= wbAddrW + , KnownNat wbBytes + , 1 <= wbBytes + , 1 <= bufferBytes + ) => -- | Minimum number of bytes that can be stored in the buffer, will be rounded up -- to the nearest multiple of wbBytes. SNat bufferBytes -> @@ -222,39 +241,42 @@ wbAxisRxBuffer :: -- 1. Wishbone slave bus -- 2. Axi4 Stream slave bus -- 3. Status - "" ::: - ( "wbS2M" ::: Signal dom (WishboneS2M (Bytes wbBytes)) - , "axisS2M" ::: Signal dom Axi4StreamS2M - , "status" ::: Signal dom (EndOfPacket, BufferFull) - ) + "" + ::: ( "wbS2M" ::: Signal dom (WishboneS2M (Bytes wbBytes)) + , "axisS2M" ::: Signal dom Axi4StreamS2M + , "status" ::: Signal dom (EndOfPacket, BufferFull) + ) wbAxisRxBuffer SNat = case strictlyPositiveDivRu @bufferBytes @wbBytes of Dict -> case leMult @wbBytes @(DivRU bufferBytes wbBytes) of Dict -> wbAxisRxBuffer# (SNat @(DivRU bufferBytes wbBytes)) +{- | A wishbone accessible buffer of configurable depth that can store a single Axi4Stream packet. +A read transfer from the buffer takes at least two cycles to complete. --- | A wishbone accessible buffer of configurable depth that can store a single Axi4Stream packet. --- A read transfer from the buffer takes at least two cycles to complete. --- --- The wishbone interface offers access to the buffer and exposes a status register that indicates: --- * If the buffer contains a packet --- * If the buffer is full before, but does not contain a whole packet. --- --- The wishbone addressing must be 4 byte aligned and is as follows: --- 0 .. (bufferBytes - 1) = Read-only access into the buffer. --- bufferBytes = Byte count register. --- (bufferBytes + 4) = Status register --- --- After reading a packet, the byte count must be set to 0 and the status register must be --- cleared. The incoming Axi4Stream interface contains a side channel that can be used to abort --- the incoming packet. If a packet is aborted, the buffer will consume the remaining transfers --- until the end of the packet is reached, after which it will reset the buffer to its initial state. +The wishbone interface offers access to the buffer and exposes a status register that indicates: + * If the buffer contains a packet + * If the buffer is full before, but does not contain a whole packet. + +The wishbone addressing must be 4 byte aligned and is as follows: + 0 .. (bufferBytes - 1) = Read-only access into the buffer. + bufferBytes = Byte count register. + (bufferBytes + 4) = Status register + +After reading a packet, the byte count must be set to 0 and the status register must be +cleared. The incoming Axi4Stream interface contains a side channel that can be used to abort +the incoming packet. If a packet is aborted, the buffer will consume the remaining transfers +until the end of the packet is reached, after which it will reset the buffer to its initial state. +-} wbAxisRxBuffer# :: - forall dom wbAddrW wbBytes fifoDepth . + forall dom wbAddrW wbBytes fifoDepth. ( HiddenClockResetEnable dom - , KnownNat wbAddrW, 2 <= wbAddrW - , KnownNat wbBytes, 1 <= wbBytes + , KnownNat wbAddrW + , 2 <= wbAddrW + , KnownNat wbBytes + , 1 <= wbBytes , 1 <= fifoDepth - , 1 <= wbBytes * fifoDepth) => + , 1 <= wbBytes * fifoDepth + ) => -- | Depth of the buffer, each entry in the buffer stores `nBytes` bytes. SNat fifoDepth -> -- | Wishbone master bus. @@ -265,20 +287,24 @@ wbAxisRxBuffer# :: -- 1. Wishbone slave bus -- 2. Axi4 Stream slave bus -- 3. Status - "" ::: - ( "wbS2M" ::: Signal dom (WishboneS2M (Bytes wbBytes)) - , "axisS2M" ::: Signal dom Axi4StreamS2M - , "status" ::: Signal dom (EndOfPacket, BufferFull) - ) + "" + ::: ( "wbS2M" ::: Signal dom (WishboneS2M (Bytes wbBytes)) + , "axisS2M" ::: Signal dom Axi4StreamS2M + , "status" ::: Signal dom (EndOfPacket, BufferFull) + ) wbAxisRxBuffer# fifoDepth@SNat wbM2S axisM2S = (wbS2M, axisS2M, statusReg) - where - fifoOut = - blockRamU NoClearOnReset fifoDepth + where + fifoOut = + blockRamU + NoClearOnReset + fifoDepth (const $ errorX "wbAxisRxBuffer: reset function undefined") - bramAddr bramWrite - (wbS2M, axisS2M, bramAddr, bramWrite, statusReg) = - mealyB go initState (wbM2S, axisM2S, fifoOut) - initState = WbAxisRxBufferState + bramAddr + bramWrite + (wbS2M, axisS2M, bramAddr, bramWrite, statusReg) = + mealyB go initState (wbM2S, axisM2S, fifoOut) + initState = + WbAxisRxBufferState { readingBuffer = False , packetLength = 0 , writeCounter = 0 @@ -286,30 +312,31 @@ wbAxisRxBuffer# fifoDepth@SNat wbM2S axisM2S = (wbS2M, axisS2M, statusReg) , bufferFull = False , abortPacket = False } - go :: - WbAxisRxBufferState fifoDepth wbBytes -> - ( WishboneM2S wbAddrW wbBytes (Bytes wbBytes) - , Maybe (Axi4StreamM2S ('Axi4StreamConfig wbBytes 0 0) Bool) - , Bytes wbBytes - ) -> - ( WbAxisRxBufferState fifoDepth wbBytes - , ( WishboneS2M (Bytes wbBytes) - , Axi4StreamS2M, Index fifoDepth - , Maybe (Index fifoDepth, Bytes wbBytes) - , (EndOfPacket, BufferFull) - ) + go :: + WbAxisRxBufferState fifoDepth wbBytes -> + ( WishboneM2S wbAddrW wbBytes (Bytes wbBytes) + , Maybe (Axi4StreamM2S ('Axi4StreamConfig wbBytes 0 0) Bool) + , Bytes wbBytes + ) -> + ( WbAxisRxBufferState fifoDepth wbBytes + , ( WishboneS2M (Bytes wbBytes) + , Axi4StreamS2M + , Index fifoDepth + , Maybe (Index fifoDepth, Bytes wbBytes) + , (EndOfPacket, BufferFull) ) - go - WbAxisRxBufferState{..} - ~(WishboneM2S{..}, maybeAxisM2S, wbData) - = (newState, output) + ) + go + WbAxisRxBufferState{..} + ~(WishboneM2S{..}, maybeAxisM2S, wbData) = + (newState, output) where masterActive = busCycle && strobe (alignedAddress, alignment) = split @_ @(wbAddrW - 2) @2 addr packetLengthAddress = maxBound - 1 - statusAddress = maxBound - internalAddress = (bitCoerce $ resize alignedAddress) :: Index (fifoDepth + 2) + statusAddress = maxBound + internalAddress = (bitCoerce $ resize alignedAddress) :: Index (fifoDepth + 2) err = masterActive && (alignment /= 0 || alignedAddress > resize (pack statusAddress)) statusBV = pack (packetComplete, bufferFull) @@ -336,87 +363,101 @@ wbAxisRxBuffer# fifoDepth@SNat wbM2S axisM2S = (wbS2M, axisS2M, statusReg) -- Next state (nextPacketComplete, nextBufferFull) - | wbAcknowledge && writeEnable && internalAddress == statusAddress - = unpack $ resize writeData + | wbAcknowledge && writeEnable && internalAddress == statusAddress = + unpack $ resize writeData | axisHandshake = - ( packetComplete || maybe False _tlast maybeAxisM2S - , bufferFull || writeCounter == maxBound - ) + ( packetComplete || maybe False _tlast maybeAxisM2S + , bufferFull || writeCounter == maxBound + ) | otherwise = unpack $ statusBV nextWriteCounter - | axisHandshake = satSucc SatBound writeCounter - | packetComplete || bufferFull = 0 - | otherwise = writeCounter + | axisHandshake = satSucc SatBound writeCounter + | packetComplete || bufferFull = 0 + | otherwise = writeCounter - popCountKeep = leToPlus @1 @wbBytes popCountBV . pack ._tkeep + popCountKeep = leToPlus @1 @wbBytes popCountBV . pack . _tkeep bytesInStream = maybe (0 :: Index (wbBytes + 1)) popCountKeep maybeAxisM2S nextPacketLength - | wbAcknowledge && writeEnable && internalAddress == packetLengthAddress - = unpack $ resize writeData - | axisHandshake - = satAdd SatBound packetLength (bitCoerce $ resize bytesInStream) - | otherwise - = packetLength + | wbAcknowledge && writeEnable && internalAddress == packetLengthAddress = + unpack $ resize writeData + | axisHandshake = + satAdd SatBound packetLength (bitCoerce $ resize bytesInStream) + | otherwise = + packetLength newState | abortPacket && maybe False _tlast maybeAxisM2S = initState - | otherwise = WbAxisRxBufferState - { readingBuffer = nextReadingBuffer - , packetLength = nextPacketLength - , writeCounter = nextWriteCounter - , packetComplete = nextPacketComplete - , bufferFull = nextBufferFull - , abortPacket = abortPacket || maybe False _tuser maybeAxisM2S - } - -data BufferState fifoDepth wbBytes = AwaitingData | BufferFull | PacketComplete (Index (wbBytes * fifoDepth + 1)) + | otherwise = + WbAxisRxBufferState + { readingBuffer = nextReadingBuffer + , packetLength = nextPacketLength + , writeCounter = nextWriteCounter + , packetComplete = nextPacketComplete + , bufferFull = nextBufferFull + , abortPacket = abortPacket || maybe False _tuser maybeAxisM2S + } + +data BufferState fifoDepth wbBytes + = AwaitingData + | BufferFull + | PacketComplete (Index (wbBytes * fifoDepth + 1)) deriving (Generic, NFDataX, Show) -data ReadStateMachine fifoDepth = - Idle | ReadingPacketSize | ReadingPacket (Index (fifoDepth + 1)) | ClearingPacketLength | ClearingStatus +data ReadStateMachine fifoDepth + = Idle + | ReadingPacketSize + | ReadingPacket (Index (fifoDepth + 1)) + | ClearingPacketLength + | ClearingStatus deriving (Generic, NFDataX, Show) --- | Circuit capable of reading the wishbone interface of @wbAxisRxBuffer@ and --- extracting Axi packets. Mostly useful for verification, but can be synthesized. --- The internal statemachine continuously reads the satus register of the buffer, --- if the buffer is full or a packet is complete, it will: --- --- 1. Read the packet length from the buffer. --- 2. Read the packet from the buffer. --- 3. Clear the packet length. --- 4. Clear the status register. +{- | Circuit capable of reading the wishbone interface of @wbAxisRxBuffer@ and +extracting Axi packets. Mostly useful for verification, but can be synthesized. +The internal statemachine continuously reads the satus register of the buffer, +if the buffer is full or a packet is complete, it will: + +1. Read the packet length from the buffer. +2. Read the packet from the buffer. +3. Clear the packet length. +4. Clear the status register. +-} rxReadMasterC :: - forall dom nBytes addrWidth bufferBytes . + forall dom nBytes addrWidth bufferBytes. ( HiddenClockResetEnable dom , 1 <= bufferBytes , 1 <= nBytes , KnownNat addrWidth - , KnownNat nBytes) => + , KnownNat nBytes + ) => SNat bufferBytes -> Circuit - () - (Wishbone dom 'Standard addrWidth (Bytes nBytes), Axi4Stream dom ('Axi4StreamConfig nBytes 0 0) ()) + () + ( Wishbone dom 'Standard addrWidth (Bytes nBytes) + , Axi4Stream dom ('Axi4StreamConfig nBytes 0 0) () + ) rxReadMasterC s = case cancelMulDiv @nBytes @8 of - Dict -> fromSignals $ \ (_, bwd) -> ((), rxReadMaster s bwd) + Dict -> fromSignals $ \(_, bwd) -> ((), rxReadMaster s bwd) --- | Circuit capable of reading the wishbone interface of @wbAxisRxBuffer@ and --- extracting Axi packets. Mostly useful for verification, but can be synthesized. --- The internal statemachine continuously reads the satus register of the buffer, --- if the buffer is full or a packet is complete, it will: --- --- 1. Read the packet length from the buffer. --- 2. Read the packet from the buffer. --- 3. Clear the packet length. --- 4. Clear the status register. +{- | Circuit capable of reading the wishbone interface of @wbAxisRxBuffer@ and +extracting Axi packets. Mostly useful for verification, but can be synthesized. +The internal statemachine continuously reads the satus register of the buffer, +if the buffer is full or a packet is complete, it will: + +1. Read the packet length from the buffer. +2. Read the packet from the buffer. +3. Clear the packet length. +4. Clear the status register. +-} rxReadMaster :: - forall dom wbBytes addrWidth bufferBytes . + forall dom wbBytes addrWidth bufferBytes. ( HiddenClockResetEnable dom , 1 <= bufferBytes , 1 <= wbBytes , KnownNat addrWidth - , KnownNat wbBytes) => + , KnownNat wbBytes + ) => SNat bufferBytes -> ( Signal dom (WishboneS2M (Bytes wbBytes)) , Signal dom Axi4StreamS2M @@ -428,22 +469,24 @@ rxReadMaster SNat = case strictlyPositiveDivRu @bufferBytes @wbBytes of Dict -> case leMult @wbBytes @(DivRU bufferBytes wbBytes) of Dict -> rxReadMaster# (SNat @(DivRU bufferBytes wbBytes)) --- | Circuit capable of reading the wishbone interface of @wbAxisRxBuffer@ and --- extracting Axi packets. Mostly useful for verification, but can be synthesized. --- The internal statemachine continuously reads the satus register of the buffer, --- if the buffer is full or a packet is complete, it will: --- --- 1. Read the packet length from the buffer. --- 2. Read the packet from the buffer. --- 3. Clear the packet length. --- 4. Clear the status register. +{- | Circuit capable of reading the wishbone interface of @wbAxisRxBuffer@ and +extracting Axi packets. Mostly useful for verification, but can be synthesized. +The internal statemachine continuously reads the satus register of the buffer, +if the buffer is full or a packet is complete, it will: + +1. Read the packet length from the buffer. +2. Read the packet from the buffer. +3. Clear the packet length. +4. Clear the status register. +-} rxReadMaster# :: - forall dom wbBytes addrWidth fifoDepth . + forall dom wbBytes addrWidth fifoDepth. ( HiddenClockResetEnable dom , 1 <= fifoDepth , 1 <= wbBytes , KnownNat addrWidth - , KnownNat wbBytes) => + , KnownNat wbBytes + ) => SNat fifoDepth -> ( Signal dom (WishboneS2M (Bytes wbBytes)) , Signal dom Axi4StreamS2M @@ -452,18 +495,18 @@ rxReadMaster# :: , Signal dom (Maybe (Axi4StreamM2S ('Axi4StreamConfig wbBytes 0 0) ())) ) rxReadMaster# SNat = mealyB go (AwaitingData @fifoDepth @wbBytes, Idle) - where - go - (bufState, readState :: ReadStateMachine fifoDepth) - ~(WishboneS2M{..}, Axi4StreamS2M{..}) = (nextState, (wbM2S, axiM2S)) + where + go + (bufState, readState :: ReadStateMachine fifoDepth) + ~(WishboneS2M{..}, Axi4StreamS2M{..}) = (nextState, (wbM2S, axiM2S)) where -- Driving wishbone signals (writeEnable, addr) = case readState of - Idle -> (False, natToNum @(4 * (1 + fifoDepth))) - ClearingStatus -> (True, natToNum @(4 * (1 + fifoDepth))) - ReadingPacketSize -> (False, natToNum @(4 * fifoDepth)) + Idle -> (False, natToNum @(4 * (1 + fifoDepth))) + ClearingStatus -> (True, natToNum @(4 * (1 + fifoDepth))) + ReadingPacketSize -> (False, natToNum @(4 * fifoDepth)) ClearingPacketLength -> (True, natToNum @(4 * fifoDepth)) - ReadingPacket i -> (False, 4 * checkedResize (pack i)) + ReadingPacket i -> (False, 4 * checkedResize (pack i)) wbM2S = WishboneM2S{..} busCycle = True @@ -483,42 +526,45 @@ rxReadMaster# SNat = mealyB go (AwaitingData @fifoDepth @wbBytes, Idle) _ -> (repeat True, False) axiM2S = case (readState, acknowledge) of - (ReadingPacket _, True) -> Just Axi4StreamM2S {..} - _ -> Nothing + (ReadingPacket _, True) -> Just Axi4StreamM2S{..} + _ -> Nothing -- Statemachine control - nextState = if not acknowledge then (bufState, readState) else - case (readState, bufState) of - (Idle,_) -> case (packetComplete, bufferFull) of - (True, _) -> (AwaitingData, ReadingPacketSize) - (_, True) -> (BufferFull, ReadingPacket minBound) - _ -> (AwaitingData, Idle) - where - (packetComplete, bufferFull) = unpack $ resize readData - (ReadingPacketSize,_) -> (PacketComplete packetSize, ReadingPacket 0) + nextState = + if not acknowledge + then (bufState, readState) + else case (readState, bufState) of + (Idle, _) -> case (packetComplete, bufferFull) of + (True, _) -> (AwaitingData, ReadingPacketSize) + (_, True) -> (BufferFull, ReadingPacket minBound) + _ -> (AwaitingData, Idle) + where + (packetComplete, bufferFull) = unpack $ resize readData + (ReadingPacketSize, _) -> (PacketComplete packetSize, ReadingPacket 0) where packetSize = unpack $ checkedResize readData - (ReadingPacket i, _) - | _tready && lastBytes bufState nextReadState -> (bufState, ClearingPacketLength) - | _tready -> (bufState, nextReadState) - | otherwise -> (bufState, readState) + (ReadingPacket i, _) + | _tready && lastBytes bufState nextReadState -> (bufState, ClearingPacketLength) + | _tready -> (bufState, nextReadState) + | otherwise -> (bufState, readState) where - nextReadState = ReadingPacket (satSucc SatBound i ) - (ClearingPacketLength, _) -> (bufState, ClearingStatus) - (ClearingStatus,_) -> (AwaitingData, Idle) + nextReadState = ReadingPacket (satSucc SatBound i) + (ClearingPacketLength, _) -> (bufState, ClearingStatus) + (ClearingStatus, _) -> (AwaitingData, Idle) lastBytes (PacketComplete s) (ReadingPacket i) = s <= (4 * checkedResize i) lastBytes BufferFull (ReadingPacket i) = i == maxBound lastBytes _ _ = False --- | Convert a @n@ number of bytes to an @m@ byte enable Vector to be used with Axi4Stream. --- --- >>> mkKeep @8 @4 3 --- True :> True :> True :> False :> Nil --- >>> mkKeep @8 @4 7 --- True :> True :> True :> True :> Nil +{- | Convert a @n@ number of bytes to an @m@ byte enable Vector to be used with Axi4Stream. + +>>> mkKeep @8 @4 3 +True :> True :> True :> False :> Nil +>>> mkKeep @8 @4 7 +True :> True :> True :> True :> Nil +-} mkKeep :: - forall maxIndex byteEnables . + forall maxIndex byteEnables. ( KnownNat maxIndex , KnownNat byteEnables ) => @@ -533,14 +579,17 @@ mkKeep nBytes type AxiStreamBytesOnly nBytes = 'Axi4StreamConfig nBytes 0 0 -- TODO: Replace with PacketStream --- | Wishbone to Axi4Stream interface, write operations to address 0 write to the Axi4Stream. --- The _tkeep bits are set based on the busSelect bits, when writing to address 1, a transfer --- is created that contains no data, but has the _tlast bit set. + +{- | Wishbone to Axi4Stream interface, write operations to address 0 write to the Axi4Stream. +The _tkeep bits are set based on the busSelect bits, when writing to address 1, a transfer +is created that contains no data, but has the _tlast bit set. +-} wbToAxiTx :: - forall dom addrW nBytes . - ( KnownNat addrW - , 2 <= addrW - , KnownNat nBytes) => + forall dom addrW nBytes. + ( KnownNat addrW + , 2 <= addrW + , KnownNat nBytes + ) => Circuit (Wishbone dom 'Standard addrW (Bytes nBytes)) (Axi4Stream dom (AxiStreamBytesOnly nBytes) ()) @@ -550,7 +599,7 @@ wbToAxiTx = case cancelMulDiv @nBytes @8 of go (WishboneM2S{..}, Axi4StreamS2M{..}) = (WishboneS2M{readData, err, acknowledge, retry, stall}, axiM2S) where - (internalAddress, alignment) = split @_ @(addrW -2) @2 addr + (internalAddress, alignment) = split @_ @(addrW - 2) @2 addr masterActive = busCycle && strobe addrValid = shiftR internalAddress 1 == 0 && alignment == 0 err = masterActive && not (addrValid && writeEnable) @@ -560,7 +609,7 @@ wbToAxiTx = case cancelMulDiv @nBytes @8 of stall = False (_tkeep, _tlast) | lsb internalAddress == 0 = (reverse $ unpack busSelect, False) - | otherwise = (repeat False, True) + | otherwise = (repeat False, True) _tstrb = repeat False _tid = 0 @@ -578,16 +627,19 @@ data AxiPacketFifoState maxPackets = AxiPacketFifoState deriving (Generic, NFDataX, Show) -- TODO: Replace with PacketStream --- | A Fifo circuit for Axi4Stream that stores an entire packet before --- producing the packet at the output. If the fifo is full, it will start transmitting --- the packet at the output. + +{- | A Fifo circuit for Axi4Stream that stores an entire packet before +producing the packet at the output. If the fifo is full, it will start transmitting +the packet at the output. +-} axiStreamPacketFifo :: - forall dom nBytes fifoDepth maxPackets userType . + forall dom nBytes fifoDepth maxPackets userType. ( HiddenClockResetEnable dom , 2 <= fifoDepth , KnownNat nBytes , 1 <= maxPackets - , NFDataX userType) => + , NFDataX userType + ) => SNat maxPackets -> SNat fifoDepth -> Circuit @@ -597,7 +649,6 @@ axiStreamPacketFifo SNat fifoDepth@SNat = AS.forceResetSanity |> Circuit goCircu where goCircuit ~(lhsM2S, fmap _tready -> outputReady) = (Axi4StreamS2M <$> inputReady, output) where - -- I/O Combinatorials inputReady = consumeAxi .&&. fifoReady output = mux produceFifo fifoOut0 (pure Nothing) @@ -606,8 +657,10 @@ axiStreamPacketFifo SNat fifoDepth@SNat = AS.forceResetSanity |> Circuit goCircu -- Fifo axiProxy = Proxy @(Axi4Stream dom (AxiStreamBytesOnly nBytes) userType) fifo = DfConv.fifo axiProxy axiProxy fifoDepth - (fmap _tready -> fifoReady, fifoOut0) = toSignals fifo - (fifoIn, Axi4StreamS2M <$> (produceFifo .&&. outputReady)) + (fmap _tready -> fifoReady, fifoOut0) = + toSignals + fifo + (fifoIn, Axi4StreamS2M <$> (produceFifo .&&. outputReady)) -- I/O Control initState = AxiPacketFifoState 0 (repeat False) False :: AxiPacketFifoState maxPackets @@ -624,22 +677,28 @@ axiStreamPacketFifo SNat fifoDepth@SNat = AS.forceResetSanity |> Circuit goCircu stallInp = packetCount == maxBound && or newPacketSr consumeInp = not stallInp dumpPacket1 = - (not dumpPacket && isJust inpM2S && not fifoReady1) - || (dumpPacket && maybe False _tlast inpM2S) + (not dumpPacket && isJust inpM2S && not fifoReady1) + || (dumpPacket && maybe False _tlast inpM2S) produceOut = dumpPacket || packetCount /= minBound newPacketSr1 = newPacketSr <<+ addPacket nextState - | stallInp = s{packetCount = packetCount1} + | stallInp = s{packetCount = packetCount1} | otherwise = AxiPacketFifoState packetCount2 newPacketSr1 dumpPacket1 -- TODO: Add test that verifies throughput requirements. --- | Circuit to convert a sparse stream into a contiguous stream while remaining the throughput of --- the input stream. + +{- | Circuit to convert a sparse stream into a contiguous stream while remaining the throughput of +the input stream. +-} axiPacking :: - forall dom dataWidth idWidth destWidth . + forall dom dataWidth idWidth destWidth. ( HiddenClockResetEnable dom - , 1 <= dataWidth, KnownNat dataWidth, KnownNat idWidth, KnownNat destWidth) => + , 1 <= dataWidth + , KnownNat dataWidth + , KnownNat idWidth + , KnownNat destWidth + ) => Circuit (Axi4Stream dom ('Axi4StreamConfig dataWidth idWidth destWidth) ()) (PackedAxi4Stream dom ('Axi4StreamConfig dataWidth idWidth destWidth) ()) @@ -659,7 +718,7 @@ axiPacking = AS.forceResetSanity |> Circuit (mealyB go Nothing) extendedAxi = fmap extendAxi axiStored packedAxi = fmap packAxi4Stream $ combinedAxi <|> extendedAxi - (outputBuffer, excessBuffer) = splitAxi4Stream $ fmap (axiUserMap (const ((),()))) packedAxi + (outputBuffer, excessBuffer) = splitAxi4Stream $ fmap (axiUserMap (const ((), ()))) packedAxi -- Output the pre-shifted axi if we can not shift anymore. shiftingDone = not dropInput && maybe False isPackedTransfer outputBuffer @@ -668,16 +727,16 @@ axiPacking = AS.forceResetSanity |> Circuit (mealyB go Nothing) -- Flow control (axiNext, inputReady) - | dropInput = (axiStored, True) -- Drop the input - | shiftingDone && outputReady = (excessBuffer, isJust combinedAxi) -- valid output, accepted - | shiftingDone && not outputReady = (axiStored, False) -- valid output, not accepted + | dropInput = (axiStored, True) -- Drop the input + | shiftingDone && outputReady = (excessBuffer, isJust combinedAxi) -- valid output, accepted + | shiftingDone && not outputReady = (axiStored, False) -- valid output, not accepted | not shiftingDone && isJust input = (outputBuffer, isJust combinedAxi) -- Shift when input - | not shiftingDone && capturedLast = (outputBuffer, False) -- Shift when captured _tlast - | otherwise = (axiStored, False) -- No input + | not shiftingDone && capturedLast = (outputBuffer, False) -- Shift when captured _tlast + | otherwise = (axiStored, False) -- No input -- | Integrated logic analyzer for an Axi4Stream bus, it captures the data, keep, ready and last signals. ilaAxi4Stream :: - forall dom conf userType . + forall dom conf userType. (HiddenClock dom, KnownAxi4StreamConfig conf) => -- | Number of registers to insert at each probe. Supported values: 0-6. -- Corresponds to @C_INPUT_PIPE_STAGES@. Default is @0@. @@ -691,39 +750,46 @@ ilaAxi4Stream :: ilaAxi4Stream stages0 depth0 = Circuit $ \(m2s, s2m) -> let ilaInst :: Signal dom () - ilaInst = ila - (ilaConfig $ - "m2s_tdata" - :> "m2s_tkeep" - :> "m2s_tlast" - :> "s2m_tready" - :> Nil) { advancedTriggers = True, stages = stages0, depth = depth0 } - hasClock - (_tdata . fromJust <$> m2s) - (_tkeep . fromJust <$> m2s) - (_tlast . fromJust <$> m2s) - (_tready <$> s2m) - in + ilaInst = + ila + ( ilaConfig + $ "m2s_tdata" + :> "m2s_tkeep" + :> "m2s_tlast" + :> "s2m_tready" + :> Nil + ) + { advancedTriggers = True + , stages = stages0 + , depth = depth0 + } + hasClock + (_tdata . fromJust <$> m2s) + (_tkeep . fromJust <$> m2s) + (_tlast . fromJust <$> m2s) + (_tready <$> s2m) + in ilaInst `hwSeqX` (s2m, m2s) --- | A packed transfer is a transfer where either: --- * _tlast is not set and all _tkeep bits are set. --- * _tlast is set and only the first n _tkeep bits are set. --- >>> let mkAxi keep last = Axi4StreamM2S @('Axi4StreamConfig 2 0 0) (repeat 0) keep (repeat True) last 0 0 () --- >>> isPackedTransfer $ mkAxi (False :> False :> Nil) False --- False --- >>> isPackedTransfer $ mkAxi (True :> False :> Nil) False --- False --- >>> isPackedTransfer $ mkAxi (True :> True :> Nil) False --- True --- >>> isPackedTransfer $ mkAxi (False :> False :> Nil) True --- True --- >>> isPackedTransfer $ mkAxi (False :> True :> Nil) True --- False -isPackedTransfer :: KnownNat (DataWidth conf) => Axi4StreamM2S conf a -> Bool +{- | A packed transfer is a transfer where either: +* _tlast is not set and all _tkeep bits are set. +* _tlast is set and only the first n _tkeep bits are set. +>>> let mkAxi keep last = Axi4StreamM2S @('Axi4StreamConfig 2 0 0) (repeat 0) keep (repeat True) last 0 0 () +>>> isPackedTransfer $ mkAxi (False :> False :> Nil) False +False +>>> isPackedTransfer $ mkAxi (True :> False :> Nil) False +False +>>> isPackedTransfer $ mkAxi (True :> True :> Nil) False +True +>>> isPackedTransfer $ mkAxi (False :> False :> Nil) True +True +>>> isPackedTransfer $ mkAxi (False :> True :> Nil) True +False +-} +isPackedTransfer :: (KnownNat (DataWidth conf)) => Axi4StreamM2S conf a -> Bool isPackedTransfer Axi4StreamM2S{..} | _tlast = not $ hasGaps _tkeep | otherwise = and _tkeep where rising = snd . mapAccumL (\prevKeep keep -> (keep, not prevKeep && keep)) True - hasGaps = or . rising + hasGaps = or . rising diff --git a/bittide/src/Bittide/Axi4/Internal.hs b/bittide/src/Bittide/Axi4/Internal.hs index 07bff7e94..d014869d6 100644 --- a/bittide/src/Bittide/Axi4/Internal.hs +++ b/bittide/src/Bittide/Axi4/Internal.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_HADDOCK hide #-} @@ -9,11 +8,11 @@ module Bittide.Axi4.Internal where import Clash.Prelude +import Bittide.Extra.Maybe import Data.Maybe import Data.Proxy -import Protocols.Axi4.Stream -import Bittide.Extra.Maybe import Protocols +import Protocols.Axi4.Stream import qualified Protocols.DfConv as DfConv @@ -22,70 +21,84 @@ import qualified Protocols.DfConv as DfConv >>> import Data.Maybe -} --- | Function to move all keep, data and strobes in an Axi4Stream to the front of --- the vectors based on the _tkeep field. +{- | Function to move all keep, data and strobes in an Axi4Stream to the front of +the vectors based on the _tkeep field. +-} packAxi4Stream :: (KnownAxi4StreamConfig conf) => - Axi4StreamM2S conf userType -> Axi4StreamM2S conf userType + Axi4StreamM2S conf userType -> + Axi4StreamM2S conf userType packAxi4Stream axi = output where output = axi{_tdata = newData, _tstrb = newStrobe, _tkeep = newKeep} - (newData, newKeep, newStrobe) = unzip3 - $ fmap (\ b -> (maybe 0 fst b, isJust b, maybe False snd b)) (packVec inpVec) + (newData, newKeep, newStrobe) = + unzip3 + $ fmap (\b -> (maybe 0 fst b, isJust b, maybe False snd b)) (packVec inpVec) inpVec = orNothing <$> _tkeep axi <*> zip (_tdata axi) (_tstrb axi) --- | Function that moves all @Just@ values in a `Vec n (Maybe a)` to the front of --- the vector. --- --- >>> packVec (Just 1 :> Nothing :> Just 2 :> Nil) --- Just 1 :> Just 2 :> Nothing :> Nil --- >>> packVec (Nothing :> Nothing :> Just 3 :> Nil) --- Just 3 :> Nothing :> Nothing :> Nil -packVec :: KnownNat n => Vec n (Maybe a) -> Vec n (Maybe a) +{- | Function that moves all @Just@ values in a `Vec n (Maybe a)` to the front of +the vector. + +>>> packVec (Just 1 :> Nothing :> Just 2 :> Nil) +Just 1 :> Just 2 :> Nothing :> Nil +>>> packVec (Nothing :> Nothing :> Just 3 :> Nil) +Just 3 :> Nothing :> Nothing :> Nil +-} +packVec :: (KnownNat n) => Vec n (Maybe a) -> Vec n (Maybe a) packVec = foldr f (repeat Nothing) where f (Just a) acc = Just a +>> acc f Nothing acc = acc --- | Splits an Axi4StreamM2S into a tuple of two Axi4StreamM2S. The first contains --- all lower bytes of the transfer, the second contains the upper bytes. The first --- output contains a transfer if at least one of the corresponding keep bits is --- high, or none of the keep bits are high. The second output will contain a transfer --- only if at least one of the corresponding keep bits is high. A transfer with --- only null bytes and _tlast set will produce a transfer with _tlast set in the --- first output, the second output will be @Nothing@. +{- | Splits an Axi4StreamM2S into a tuple of two Axi4StreamM2S. The first contains +all lower bytes of the transfer, the second contains the upper bytes. The first +output contains a transfer if at least one of the corresponding keep bits is +high, or none of the keep bits are high. The second output will contain a transfer +only if at least one of the corresponding keep bits is high. A transfer with +only null bytes and _tlast set will produce a transfer with _tlast set in the +first output, the second output will be @Nothing@. +-} splitAxi4Stream :: - forall widthA widthB idWith destWidth userTypeA userTypeB . + forall widthA widthB idWith destWidth userTypeA userTypeB. ( KnownNat widthA , KnownNat widthB ) => -- | Axi4Stream transfer to split into two transfers. - Maybe (Axi4StreamM2S ('Axi4StreamConfig (widthA + widthB) idWith destWidth) (userTypeA, userTypeB)) -> + Maybe + ( Axi4StreamM2S + ('Axi4StreamConfig (widthA + widthB) idWith destWidth) + (userTypeA, userTypeB) + ) -> -- | -- 1. Axi4Stream transfer with the first half of the data, keep and strobe vectors. -- 2. Axi4Stream transfer with the second half of the data, keep and strobe vectors. ( Maybe (Axi4StreamM2S ('Axi4StreamConfig widthA idWith destWidth) userTypeA) - , Maybe (Axi4StreamM2S ('Axi4StreamConfig widthB idWith destWidth) userTypeB)) + , Maybe (Axi4StreamM2S ('Axi4StreamConfig widthB idWith destWidth) userTypeB) + ) splitAxi4Stream Nothing = (Nothing, Nothing) splitAxi4Stream (Just axi) = (orNothing aValid axiA, orNothing bValid axiB) where - axiA = Axi4StreamM2S - {_tdata = dataA - , _tkeep = keepA - , _tstrb = strbA - , _tlast = lastA - , _tid = _tid axi - , _tdest = _tdest axi - , _tuser = fst $ _tuser axi} + axiA = + Axi4StreamM2S + { _tdata = dataA + , _tkeep = keepA + , _tstrb = strbA + , _tlast = lastA + , _tid = _tid axi + , _tdest = _tdest axi + , _tuser = fst $ _tuser axi + } - axiB = Axi4StreamM2S - {_tdata = dataB - , _tkeep = keepB - , _tstrb = strbB - , _tlast = lastB - , _tid = _tid axi - , _tdest = _tdest axi - , _tuser = snd $ _tuser axi} + axiB = + Axi4StreamM2S + { _tdata = dataB + , _tkeep = keepB + , _tstrb = strbB + , _tlast = lastB + , _tid = _tid axi + , _tdest = _tdest axi + , _tuser = snd $ _tuser axi + } (dataA, dataB) = splitAtI $ _tdata axi (keepA, keepB) = splitAtI $ _tkeep axi @@ -96,16 +109,17 @@ splitAxi4Stream (Just axi) = (orNothing aValid axiA, orNothing bValid axiB) lastB = _tlast axi && bValid -- The first output is valid if: - -- * At least one of the corresponding keep bits is set - -- * None of the other keep bits are set. + -- \* At least one of the corresponding keep bits is set + -- \* None of the other keep bits are set. aValid = or keepA || lastA bValid = or keepB --- | Extends an @Axi4StreamM2S@ with null bytes. The lower indices of the vectors containing --- data, keep and strobe are copied from the input transfer. The upper indices are filled --- with null bytes. The _tlast, _tid, _tdest and _tuser fields are passed through. +{- | Extends an @Axi4StreamM2S@ with null bytes. The lower indices of the vectors containing +data, keep and strobe are copied from the input transfer. The upper indices are filled +with null bytes. The _tlast, _tid, _tdest and _tuser fields are passed through. +-} extendAxi :: - forall widthA widthB idWith destWidth userType . + forall widthA widthB idWith destWidth userType. ( KnownNat widthA , KnownNat widthB , KnownNat idWith @@ -113,21 +127,23 @@ extendAxi :: ) => Axi4StreamM2S ('Axi4StreamConfig widthA idWith destWidth) userType -> Axi4StreamM2S ('Axi4StreamConfig (widthA + widthB) idWith destWidth) userType -extendAxi axi = Axi4StreamM2S - { _tdata = _tdata axi ++ repeat 0 - , _tkeep = _tkeep axi ++ repeat False - , _tstrb = _tstrb axi ++ repeat False - , _tlast = _tlast axi - , _tid = _tid axi - , _tdest = _tdest axi - , _tuser = _tuser axi - } - --- | Combines two Axi4StreamM2S into a single Axi4StreamM2S. The data, keep and strobe --- vectors are concatenated. The first transfer must contain the lower part of the --- data, the second transfer must contain the upper part of the data. If _tlast is --- set in the first transfer, a second transfer is not allowed and the function --- will return @Nothing@. +extendAxi axi = + Axi4StreamM2S + { _tdata = _tdata axi ++ repeat 0 + , _tkeep = _tkeep axi ++ repeat False + , _tstrb = _tstrb axi ++ repeat False + , _tlast = _tlast axi + , _tid = _tid axi + , _tdest = _tdest axi + , _tuser = _tuser axi + } + +{- | Combines two Axi4StreamM2S into a single Axi4StreamM2S. The data, keep and strobe +vectors are concatenated. The first transfer must contain the lower part of the +data, the second transfer must contain the upper part of the data. If _tlast is +set in the first transfer, a second transfer is not allowed and the function +will return @Nothing@. +-} combineAxi4Stream :: forall widthA widthB idWidth destWidth userTypeA userTypeB. ( KnownNat widthA @@ -142,70 +158,81 @@ combineAxi4Stream :: -- | Second Axi4Stream transfer, should contain the upper bytes. Maybe (Axi4StreamM2S ('Axi4StreamConfig widthB idWidth destWidth) userTypeB) -> -- | Combined Axi4Stream transfer, or @Nothing@ if the transfers are not compatible. - Maybe (Axi4StreamM2S ('Axi4StreamConfig (widthA + widthB) idWidth destWidth) (userTypeA, userTypeB)) + Maybe + ( Axi4StreamM2S + ('Axi4StreamConfig (widthA + widthB) idWidth destWidth) + (userTypeA, userTypeB) + ) combineAxi4Stream maybeAxiA maybeAxiB = case (maybeAxiA, maybeAxiB) of (Just axiA, Just axiB) -> orNothing compatibleAxis axiNew where - axiNew = Axi4StreamM2S - {_tdata = _tdata axiA ++ _tdata axiB - , _tkeep = _tkeep axiA ++ _tkeep axiB - , _tstrb = _tstrb axiA ++ _tstrb axiB - , _tlast = _tlast axiB - , _tid = _tid axiA - , _tdest = _tdest axiA - , _tuser = (_tuser axiA, _tuser axiB) - } + axiNew = + Axi4StreamM2S + { _tdata = _tdata axiA ++ _tdata axiB + , _tkeep = _tkeep axiA ++ _tkeep axiB + , _tstrb = _tstrb axiA ++ _tstrb axiB + , _tlast = _tlast axiB + , _tid = _tid axiA + , _tdest = _tdest axiA + , _tuser = (_tuser axiA, _tuser axiB) + } -- We can only combine two Axi4Streams if they have the same id, dest and the first -- transfer is not the end of a packet. compatibleAxis = _tid axiA == _tid axiB && _tdest axiA == _tdest axiB && not (_tlast axiA) - - (Just axi, Nothing) -> Just $ Axi4StreamM2S - { _tdata = _tdata axi ++ repeat 0 - , _tkeep = _tkeep axi ++ repeat False - , _tstrb = _tstrb axi ++ repeat False - , _tlast = _tlast axi - , _tid = _tid axi - , _tdest = _tdest axi - , _tuser = (_tuser axi, deepErrorX "combineAxi4Stream: Undefined second _tuser") - } - - (Nothing, Just axi) -> Just $ Axi4StreamM2S - { _tdata = repeat 0 ++ _tdata axi - , _tkeep = repeat False ++ _tkeep axi - , _tstrb = repeat False ++ _tstrb axi - , _tlast = _tlast axi - , _tid = _tid axi - , _tdest = _tdest axi - , _tuser = (deepErrorX "combineAxi4Stream: Undefined first _tuser", _tuser axi) - } + (Just axi, Nothing) -> + Just + $ Axi4StreamM2S + { _tdata = _tdata axi ++ repeat 0 + , _tkeep = _tkeep axi ++ repeat False + , _tstrb = _tstrb axi ++ repeat False + , _tlast = _tlast axi + , _tid = _tid axi + , _tdest = _tdest axi + , _tuser = (_tuser axi, deepErrorX "combineAxi4Stream: Undefined second _tuser") + } + (Nothing, Just axi) -> + Just + $ Axi4StreamM2S + { _tdata = repeat 0 ++ _tdata axi + , _tkeep = repeat False ++ _tkeep axi + , _tstrb = repeat False ++ _tstrb axi + , _tlast = _tlast axi + , _tid = _tid axi + , _tdest = _tdest axi + , _tuser = (deepErrorX "combineAxi4Stream: Undefined first _tuser", _tuser axi) + } _ -> Nothing --- | A custom of `==` for Axi4StreamM2S that only checks the data bytes if they are valid. --- TODO: We should make better use of ADTs in `Axi4StreamM2S` to allow us to use derived --- typeclass instances. +{- | A custom of `==` for Axi4StreamM2S that only checks the data bytes if they are valid. +TODO: We should make better use of ADTs in `Axi4StreamM2S` to allow us to use derived +typeclass instances. +-} eqAxi4Stream :: (Eq userType, KnownAxi4StreamConfig conf) => Axi4StreamM2S conf userType -> - Axi4StreamM2S conf userType -> Bool + Axi4StreamM2S conf userType -> + Bool eqAxi4Stream axiA axiB = lastSame && idSame && destSame && userSame && and keepsSame && and bytesValid - where - keepsSame = (==) <$> _tkeep axiA <*> _tkeep axiB - lastSame = _tlast axiA == _tlast axiB - idSame = _tid axiA == _tid axiB - destSame = _tdest axiA == _tdest axiB - userSame = _tuser axiA == _tuser axiB - - -- For all bytes where the keep is high, the data and strb must be the same. - keeps = (||) <$> _tkeep axiA <*> _tkeep axiB - dataSame = (==) <$> _tdata axiA <*> _tdata axiB - strbSame = (==) <$> _tstrb axiA <*> _tstrb axiB - bytesValid = zipWith3 (\ k d s -> (not k) || (d && s)) keeps strbSame dataSame + where + keepsSame = (==) <$> _tkeep axiA <*> _tkeep axiB + lastSame = _tlast axiA == _tlast axiB + idSame = _tid axiA == _tid axiB + destSame = _tdest axiA == _tdest axiB + userSame = _tuser axiA == _tuser axiB + + -- For all bytes where the keep is high, the data and strb must be the same. + keeps = (||) <$> _tkeep axiA <*> _tkeep axiB + dataSame = (==) <$> _tdata axiA <*> _tdata axiB + strbSame = (==) <$> _tstrb axiA <*> _tstrb axiB + bytesValid = zipWith3 (\k d s -> (not k) || (d && s)) keeps strbSame dataSame -- | Extend a `Vec n a` to an arbitrary, larger size by appending `errorX` values.ip Axi4) extendWithErrorX :: - forall n m a . (KnownNat n, KnownNat m, NFDataX a) => - Vec n a -> Vec (n + m) a + forall n m a. + (KnownNat n, KnownNat m, NFDataX a) => + Vec n a -> + Vec (n + m) a extendWithErrorX = (++ deepErrorX "extendWithErrorX: Undefined") -- | Map a function over the _tuser field of an `Axi4StreamM2S. @@ -218,11 +245,12 @@ axiUserMap f axi = axi{_tuser = f (_tuser axi)} -- | Circuit version of `axiUserMap`, maps a function over the _tuser field of an `Axi4StreamM2S. axiUserMapC :: - forall dom conf userTypeA userTypeB . + forall dom conf userTypeA userTypeB. ( KnownAxi4StreamConfig conf , HiddenClockResetEnable dom , NFDataX userTypeA - , NFDataX userTypeB) => + , NFDataX userTypeB + ) => (userTypeA -> userTypeB) -> Circuit (Axi4Stream dom conf userTypeA) diff --git a/bittide/src/Bittide/Calendar.hs b/bittide/src/Bittide/Calendar.hs index 87d67f323..a52c214d2 100644 --- a/bittide/src/Bittide/Calendar.hs +++ b/bittide/src/Bittide/Calendar.hs @@ -1,36 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=8 #-} -{-| +{- | Contains the Bittide Calendar, which is a double buffered memory element that stores instructions for the 'scatterUnitWb', 'gatherUnitWb' or 'switch'. Implementation is based on the "Bittide Hardware" document. For documentation see 'Bittide.Calendar.calendar'. -|-} -{-# OPTIONS_GHC -fconstraint-solver-iterations=8 #-} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - -module Bittide.Calendar - ( calendar - , mkCalendar - , CalendarConfig(..) - , ValidEntry(..) - , ExtraRegs - , Calendar - ) where +| +-} +module Bittide.Calendar ( + calendar, + mkCalendar, + CalendarConfig (..), + ValidEntry (..), + ExtraRegs, + Calendar, +) where import Clash.Prelude -import Data.Maybe import Data.Constraint.Nat.Extra +import Data.Maybe import Protocols.Wishbone import Bittide.Extra.Maybe @@ -46,10 +45,11 @@ it does not care about the type of its entries, this type depends on the compone instantiates the calendar. -} --- | Tuple of calendar entry @a@ and repetition count @Unsigned repetitionBits@ that --- indicates the number of times the calendar entry should be repeated: --- 0 = no repetition, entry is valid for one cycle. --- 1 = repeated once, entry is valid for two cycles. +{- | Tuple of calendar entry @a@ and repetition count @Unsigned repetitionBits@ that +indicates the number of times the calendar entry should be repeated: +0 = no repetition, entry is valid for one cycle. +1 = repeated once, entry is valid for two cycles. +-} data ValidEntry a repetitionBits = ValidEntry { veEntry :: a -- ^ Calendar entry @@ -57,20 +57,26 @@ data ValidEntry a repetitionBits = ValidEntry -- ^ Number of times the calendar entry should be repeated: -- 0 = no repetition, entry is valid for one cycle. -- 1 = repeated once, entry is valid for two cycles. - } deriving (BitPack, Eq, Generic, NFDataX, Show, ShowX) + } + deriving (BitPack, Eq, Generic, NFDataX, Show, ShowX) --- | 'Vec' of 'ValidEntry's to be used by a 'calendar'. The duration of the 'Calendar' in --- clockCycles is equal to the @size@ of the 'Calendar' plus the 'sum' of all 'veRepeat's --- of the 'ValidEntry's. -type Calendar size a repetitionBits = Vec size (ValidEntry a repetitionBits) +{- | 'Vec' of 'ValidEntry's to be used by a 'calendar'. The duration of the 'Calendar' in +clockCycles is equal to the @size@ of the 'Calendar' plus the 'sum' of all 'veRepeat's +of the 'ValidEntry's. +-} +type Calendar size a repetitionBits = Vec size (ValidEntry a repetitionBits) --- | Configuration for the calendar, This type satisfies all --- relevant constraints imposed by calendar. +{- | Configuration for the calendar, This type satisfies all +relevant constraints imposed by calendar. +-} data CalendarConfig nBytes addrW a where CalendarConfig :: - ( KnownNat repetitionBits, 1 <= 2^repetitionBits -- This can be removed after https://github.com/clash-lang/ghc-typelits-natnormalise/issues/65 has been fixed. - , KnownNat bootstrapActive, 1 <= bootstrapActive - , KnownNat bootstrapShadow, 1 <= bootstrapShadow + ( KnownNat repetitionBits + , 1 <= 2 ^ repetitionBits -- This can be removed after https://github.com/clash-lang/ghc-typelits-natnormalise/issues/65 has been fixed. + , KnownNat bootstrapActive + , 1 <= bootstrapActive + , KnownNat bootstrapShadow + , 1 <= bootstrapShadow , LessThan bootstrapActive maxCalDepth , LessThan bootstrapShadow maxCalDepth , Paddable a @@ -89,13 +95,17 @@ data CalendarConfig nBytes addrW a where -- | Standalone deriving is required because 'CalendarConfig' contains existential type variables. deriving instance Show (CalendarConfig nBytes addrW a) --- | Wrapper function to create a 'calendar' from the given 'CalendarConfig', this way --- we prevent the constraints of the type variables used in 'calendar' from leaking into --- the rest of the system. +{- | Wrapper function to create a 'calendar' from the given 'CalendarConfig', this way +we prevent the constraints of the type variables used in 'calendar' from leaking into +the rest of the system. +-} mkCalendar :: ( HiddenClockResetEnable dom - , KnownNat nBytes, 1 <= nBytes - , KnownNat addrW, 2 <= addrW) => + , KnownNat nBytes + , 1 <= nBytes + , KnownNat addrW + , 2 <= addrW + ) => -- | Calendar configuration for 'calendar'. CalendarConfig nBytes addrW calEntry -> -- | Wishbone interface (master to slave) @@ -108,81 +118,91 @@ mkCalendar :: mkCalendar (CalendarConfig maxCalDepth bsActive bsShadow) = calendar maxCalDepth bsActive bsShadow --- | State of the calendar excluding the buffers. It stores the depths of the active and --- shadow calendar, the read pointer, buffer selector and a register for first cycle behavior. +{- | State of the calendar excluding the buffers. It stores the depths of the active and +shadow calendar, the read pointer, buffer selector and a register for first cycle behavior. +-} data CalendarState maxCalDepth repetitionBits = CalendarState - { firstCycle :: Bool - -- ^ is True after reset, becomes false after first cycle. - , selectedBuffer :: AorB - -- ^ Indicates if buffer A or B is active. - , entryTracker :: Index maxCalDepth - -- ^ Read point for the active calendar. + { firstCycle :: Bool + -- ^ is True after reset, becomes false after first cycle. + , selectedBuffer :: AorB + -- ^ Indicates if buffer A or B is active. + , entryTracker :: Index maxCalDepth + -- ^ Read point for the active calendar. , repetitionCounter :: Unsigned repetitionBits - -- ^ Counts the number of cycles that the current entry has been repeated. - , calDepthA :: Index maxCalDepth - -- ^ Depth of buffer A. - , calDepthB :: Index maxCalDepth - -- ^ Depth of buffer B. - , swapCalendars :: Bool - -- ^ Swaps the active and shadow calendar at the end of the metacycle. - } deriving (Generic, NFDataX) - --- | Contains the current active calendar entry along with the metacycle --- indicator that is provided at the output of the the calendar component. Furthermore --- it contains the shadow entry and depth of the shadow calendar which are provided --- to the wishbone output hardware ('wbCalTX'). + -- ^ Counts the number of cycles that the current entry has been repeated. + , calDepthA :: Index maxCalDepth + -- ^ Depth of buffer A. + , calDepthB :: Index maxCalDepth + -- ^ Depth of buffer B. + , swapCalendars :: Bool + -- ^ Swaps the active and shadow calendar at the end of the metacycle. + } + deriving (Generic, NFDataX) + +{- | Contains the current active calendar entry along with the metacycle +indicator that is provided at the output of the the calendar component. Furthermore +it contains the shadow entry and depth of the shadow calendar which are provided +to the wishbone output hardware ('wbCalTX'). +-} data CalendarOutput calDepth calEntry = CalendarOutput - { activeEntry :: calEntry - -- ^ Current active entry. - , lastCycle :: Bool - -- ^ True when the last entry of the active calendar is present at the output. - , shadowEntry :: calEntry - -- ^ Current shadow entry - , shadowDepth :: Index calDepth - -- ^ Depth of current shadow calendar. + { activeEntry :: calEntry + -- ^ Current active entry. + , lastCycle :: Bool + -- ^ True when the last entry of the active calendar is present at the output. + , shadowEntry :: calEntry + -- ^ Current shadow entry + , shadowDepth :: Index calDepth + -- ^ Depth of current shadow calendar. } -- | Contains the read and write operations for both buffers. data BufferControl calDepth calEntry = BufferControl - { readA :: Index calDepth - -- ^ Read address for buffer A. - , writeA :: Maybe (Located calDepth calEntry) - -- ^ Write operation for buffer B. - , readB :: Index calDepth - -- ^ Read address for buffer B - , writeB :: Maybe (Located calDepth calEntry) - -- ^ Write operation for buffer B. + { readA :: Index calDepth + -- ^ Read address for buffer A. + , writeA :: Maybe (Located calDepth calEntry) + -- ^ Write operation for buffer B. + , readB :: Index calDepth + -- ^ Read address for buffer B + , writeB :: Maybe (Located calDepth calEntry) + -- ^ Write operation for buffer B. } {-# NOINLINE calendar #-} --- | Hardware component that stores an active bittide calendar and a shadow bittide calendar. --- The entries of the active calendar will be sequentially provided at the output, --- the shadow calendar can be read from and written to through the wishbone interface. --- The active and shadow calendar can be swapped by setting the shadowSwitch to True. + +{- | Hardware component that stores an active bittide calendar and a shadow bittide calendar. +The entries of the active calendar will be sequentially provided at the output, +the shadow calendar can be read from and written to through the wishbone interface. +The active and shadow calendar can be swapped by setting the shadowSwitch to True. +-} calendar :: - forall dom nBytes addrW maxCalDepth a repetitionBits bootstrapSizeA bootstrapSizeB . + forall dom nBytes addrW maxCalDepth a repetitionBits bootstrapSizeA bootstrapSizeB. ( HiddenClockResetEnable dom - , KnownNat addrW, 2 <= addrW - , KnownNat bootstrapSizeA, 1 <= bootstrapSizeA - , KnownNat bootstrapSizeB, 1 <= bootstrapSizeB - , KnownNat nBytes, 1 <= nBytes + , KnownNat addrW + , 2 <= addrW + , KnownNat bootstrapSizeA + , 1 <= bootstrapSizeA + , KnownNat bootstrapSizeB + , 1 <= bootstrapSizeB + , KnownNat nBytes + , 1 <= nBytes , KnownNat repetitionBits , 2 <= maxCalDepth , LessThan bootstrapSizeA maxCalDepth , LessThan bootstrapSizeB maxCalDepth , Paddable a , ShowX a - , Show a) => - SNat maxCalDepth - -- ^ The maximum amount of entries that can be stored in the individual calendars. - -> Calendar bootstrapSizeA a repetitionBits - -- ^ Bootstrap calendar for the active buffer. - -> Calendar bootstrapSizeB a repetitionBits - -- ^ Bootstrap calendar for the shadow buffer. - -> Signal dom (WishboneM2S addrW nBytes (Bytes nBytes)) - -- ^ Incoming wishbone interface - -> (Signal dom a, Signal dom Bool, Signal dom (WishboneS2M (Bytes nBytes))) - -- ^ Currently active entry, Metacycle indicator and outgoing wishbone interface. + , Show a + ) => + -- | The maximum amount of entries that can be stored in the individual calendars. + SNat maxCalDepth -> + -- | Bootstrap calendar for the active buffer. + Calendar bootstrapSizeA a repetitionBits -> + -- | Bootstrap calendar for the shadow buffer. + Calendar bootstrapSizeB a repetitionBits -> + -- | Incoming wishbone interface + Signal dom (WishboneM2S addrW nBytes (Bytes nBytes)) -> + -- | Currently active entry, Metacycle indicator and outgoing wishbone interface. + (Signal dom a, Signal dom Bool, Signal dom (WishboneS2M (Bytes nBytes))) calendar SNat bootstrapActive bootstrapShadow wbIn = (veEntry . activeEntry <$> calOut, lastCycle <$> calOut, wbOut) where @@ -196,10 +216,14 @@ calendar SNat bootstrapActive bootstrapShadow wbIn = -- -- https://github.com/clash-lang/clash-compiler/issues/2360 -- - bootstrapA = bootstrapActive ++ repeat @(maxCalDepth - bootstrapSizeA) - ValidEntry{veEntry = unpack 0, veRepeat = 0} - bootstrapB = bootstrapShadow ++ repeat @(maxCalDepth - bootstrapSizeA) - ValidEntry{veEntry = unpack 0, veRepeat = 0} + bootstrapA = + bootstrapActive + ++ repeat @(maxCalDepth - bootstrapSizeA) + ValidEntry{veEntry = unpack 0, veRepeat = 0} + bootstrapB = + bootstrapShadow + ++ repeat @(maxCalDepth - bootstrapSizeA) + ValidEntry{veEntry = unpack 0, veRepeat = 0} bufA = blockRam bootstrapA (readA <$> bufCtrl) (writeA <$> bufCtrl) bufB = blockRam bootstrapB (readB <$> bufCtrl) (writeB <$> bufCtrl) @@ -209,22 +233,28 @@ calendar SNat bootstrapActive bootstrapShadow wbIn = -- We can safely derive the initial calDepths from the bootStrap sizes because -- we have the calDepth <= bootstrapSize constraints. Furthermore using resize -- does not require additional constraints. - initState = CalendarState - { firstCycle = True - , selectedBuffer = A - , entryTracker = 0 - , repetitionCounter = 0 - , calDepthA = resize (maxBound :: Index bootstrapSizeA) - , calDepthB = resize (maxBound :: Index bootstrapSizeB) - , swapCalendars = False - } - - go :: CalendarState maxCalDepth repetitionBits -> + initState = + CalendarState + { firstCycle = True + , selectedBuffer = A + , entryTracker = 0 + , repetitionCounter = 0 + , calDepthA = resize (maxBound :: Index bootstrapSizeA) + , calDepthB = resize (maxBound :: Index bootstrapSizeB) + , swapCalendars = False + } + + go :: + CalendarState maxCalDepth repetitionBits -> ( CalendarControl maxCalDepth (ValidEntry a repetitionBits) nBytes - , ValidEntry a repetitionBits, ValidEntry a repetitionBits) -> + , ValidEntry a repetitionBits + , ValidEntry a repetitionBits + ) -> ( CalendarState maxCalDepth repetitionBits - , (BufferControl maxCalDepth (ValidEntry a repetitionBits) - , CalendarOutput maxCalDepth (ValidEntry a repetitionBits))) + , ( BufferControl maxCalDepth (ValidEntry a repetitionBits) + , CalendarOutput maxCalDepth (ValidEntry a repetitionBits) + ) + ) go CalendarState{..} (CalendarControl{..}, bufAIn, bufBIn) = (calState, (bufCtrl1, calOut1)) where @@ -238,12 +268,12 @@ calendar SNat bootstrapActive bootstrapShadow wbIn = entryTracker1 | entryStillValid = entryTracker - | not lastCycle = satSucc SatWrap entryTracker - | otherwise = 0 + | not lastCycle = satSucc SatWrap entryTracker + | otherwise = 0 repetitionCounter1 | entryStillValid = satSucc SatWrap repetitionCounter - | otherwise = 0 + | otherwise = 0 (activeEntry1, shadowEntry) | A <- selectedBuffer = (bufAIn, bufBIn) @@ -255,114 +285,131 @@ calendar SNat bootstrapActive bootstrapShadow wbIn = (calDepthA1, calDepthB1) = case (selectedBuffer, newShadowDepth) of - (A, Just newDepthB) -> (calDepthA, newDepthB) - (B, Just newDepthA) -> (newDepthA, calDepthB) - _ -> (calDepthA, calDepthB) + (A, Just newDepthB) -> (calDepthA, newDepthB) + (B, Just newDepthA) -> (newDepthA, calDepthB) + _ -> (calDepthA, calDepthB) (readA, writeA, readB, writeB) = case (selectedBuffer1, isJust newShadowEntry) of - (A, True) -> (entryTracker1 , Nothing , shadowReadAddr, newShadowEntry) - (A, _ ) -> (entryTracker1 , Nothing , shadowReadAddr, Nothing) - (B, True) -> (shadowReadAddr, newShadowEntry, entryTracker1 , Nothing) - (B, _ ) -> (shadowReadAddr, Nothing , entryTracker1 , Nothing) + (A, True) -> (entryTracker1, Nothing, shadowReadAddr, newShadowEntry) + (A, _) -> (entryTracker1, Nothing, shadowReadAddr, Nothing) + (B, True) -> (shadowReadAddr, newShadowEntry, entryTracker1, Nothing) + (B, _) -> (shadowReadAddr, Nothing, entryTracker1, Nothing) activeEntry@(ValidEntry{..}) | firstCycle = bootstrapA !! (0 :: Index 1) - | otherwise = activeEntry1 + | otherwise = activeEntry1 bufCtrl1 = BufferControl{readA, writeA, readB, writeB} calOut1 = CalendarOutput{activeEntry, lastCycle, shadowEntry, shadowDepth} - calState = CalendarState - { firstCycle = False - , selectedBuffer = selectedBuffer1 - , entryTracker = entryTracker1 - , repetitionCounter = repetitionCounter1 - , calDepthA = calDepthA1 - , calDepthB = calDepthB1 - , swapCalendars = armCalendarSwap || (not lastCycle && swapCalendars) - } + calState = + CalendarState + { firstCycle = False + , selectedBuffer = selectedBuffer1 + , entryTracker = entryTracker1 + , repetitionCounter = repetitionCounter1 + , calDepthA = calDepthA1 + , calDepthB = calDepthB1 + , swapCalendars = armCalendarSwap || (not lastCycle && swapCalendars) + } --- | State of the calendar RX hardware, contains registers to store a new entry and --- the shadow read address. +{- | State of the calendar RX hardware, contains registers to store a new entry and +the shadow read address. +-} data WishboneRXState regSize calEntry calDepth = WishboneRXState { calStRegisters :: RegisterBank regSize calEntry 'LittleEndian - -- ^ Write entry for the shadow calendar - , calStReadAddr :: RegisterBank regSize (Index calDepth) 'LittleEndian - -- ^ Read address for the shadow calendar. - } deriving (Generic) - -instance ( KnownNat regSize - , 1 <= regSize - , KnownNat calDepth - , Paddable calEntry - , 1 <= CLog 2 calDepth - , 1 <= calDepth) => - NFDataX (WishboneRXState regSize calEntry calDepth) - --- | Control signals produced by the wishbone RX hardware for the calendar. --- The calendar's wishbone address space is as follows: --- * address 0 to n -> Registers that store a calEntry, due to the polymorphic nature of --- calEntry, multiple addresses may be required to write an entry to the shadow calendar. --- * address (n + 1) -> Writing to this address writes the calEntry stored in the registers --- at address 0 to n to the shadow calendar at the location provided by writeData. --- * address (n + 2) -> Register that stores the read address for the shadow calendar. --- * address (n + 3) -> Writing to this address updates the depth (counter wrap around point) --- for the shadow calendar. --- * address (n + 4) -> Arm the calendar to swap the active and shadow calendars at the --- end of the metacycle. + -- ^ Write entry for the shadow calendar + , calStReadAddr :: RegisterBank regSize (Index calDepth) 'LittleEndian + -- ^ Read address for the shadow calendar. + } + deriving (Generic) + +instance + ( KnownNat regSize + , 1 <= regSize + , KnownNat calDepth + , Paddable calEntry + , 1 <= CLog 2 calDepth + , 1 <= calDepth + ) => + NFDataX (WishboneRXState regSize calEntry calDepth) + +{- | Control signals produced by the wishbone RX hardware for the calendar. +The calendar's wishbone address space is as follows: + * address 0 to n -> Registers that store a calEntry, due to the polymorphic nature of + calEntry, multiple addresses may be required to write an entry to the shadow calendar. + * address (n + 1) -> Writing to this address writes the calEntry stored in the registers + at address 0 to n to the shadow calendar at the location provided by writeData. + * address (n + 2) -> Register that stores the read address for the shadow calendar. + * address (n + 3) -> Writing to this address updates the depth (counter wrap around point) + for the shadow calendar. + * address (n + 4) -> Arm the calendar to swap the active and shadow calendars at the + end of the metacycle. +-} data CalendarControl calDepth calEntry nBytes = CalendarControl { newShadowDepth :: Maybe (Index calDepth) - -- ^ The size of the next calendar + -- ^ The size of the next calendar , newShadowEntry :: Maybe (Located calDepth calEntry) - -- ^ The next entry and its write address + -- ^ The next entry and its write address , shadowReadAddr :: Index calDepth - -- ^ The next address to read from in the shadow calendar + -- ^ The next address to read from in the shadow calendar , wishboneActive :: Bool - -- ^ Is the wishbone interface currently performing an operation + -- ^ Is the wishbone interface currently performing an operation , wishboneError :: Bool - -- ^ Is the wishbone interface in an illegal state + -- ^ Is the wishbone interface in an illegal state , wishboneAddress :: WbAddress calEntry nBytes - -- ^ Address for the wishbone interface. + -- ^ Address for the wishbone interface. , armCalendarSwap :: Bool - -- ^ Swap the active and shadow calendar at the end of the metacycle. + -- ^ Swap the active and shadow calendar at the end of the metacycle. } --- | Interface that decodes incoming wishbone operations into useful signals for the --- calendar. -wbCalRX - :: forall dom calEntry calDepth addrW nBytes - . ( HiddenClockResetEnable dom - , Paddable calEntry, ShowX calEntry - , KnownNat calDepth, 2 <= calDepth - , KnownNat addrW, 2 <= addrW - , KnownNat nBytes, 1 <= nBytes) - => Signal dom (WishboneM2S addrW nBytes (Bytes nBytes)) - -- ^ Incoming wishbone signals - -> Signal dom (CalendarControl calDepth calEntry nBytes) - -- ^ Calendar control signals. +{- | Interface that decodes incoming wishbone operations into useful signals for the +calendar. +-} +wbCalRX :: + forall dom calEntry calDepth addrW nBytes. + ( HiddenClockResetEnable dom + , Paddable calEntry + , ShowX calEntry + , KnownNat calDepth + , 2 <= calDepth + , KnownNat addrW + , 2 <= addrW + , KnownNat nBytes + , 1 <= nBytes + ) => + -- | Incoming wishbone signals + Signal dom (WishboneM2S addrW nBytes (Bytes nBytes)) -> + -- | Calendar control signals. + Signal dom (CalendarControl calDepth calEntry nBytes) wbCalRX = case oneLeCLog2n @calDepth of Dict -> mealy go initState where - initState = WishboneRXState - { calStRegisters = deepErrorX "wbCalRX: calStRegisters undefined." - , calStReadAddr = deepErrorX "wbCalRX: calStReadAddr undefined." - } + initState = + WishboneRXState + { calStRegisters = deepErrorX "wbCalRX: calStRegisters undefined." + , calStReadAddr = deepErrorX "wbCalRX: calStReadAddr undefined." + } - go :: WishboneRXState (nBytes * 8) calEntry calDepth - -> WishboneM2S addrW nBytes (Bytes nBytes) - -> ( WishboneRXState (nBytes * 8) calEntry calDepth - , CalendarControl calDepth calEntry nBytes - ) + go :: + WishboneRXState (nBytes * 8) calEntry calDepth -> + WishboneM2S addrW nBytes (Bytes nBytes) -> + ( WishboneRXState (nBytes * 8) calEntry calDepth + , CalendarControl calDepth calEntry nBytes + ) go wbState@WishboneRXState{..} WishboneM2S{..} = (wbState1, calControl) where calEntryRegs = natToNum @(Regs calEntry (nBytes * 8)) (alignedAddress, alignment) = split @_ @(addrW - 2) @2 addr - wbAddrValid = alignedAddress <= resize (pack (maxBound :: WbAddress calEntry nBytes)) - && alignment == 0 + wbAddrValid = + alignedAddress + <= resize (pack (maxBound :: WbAddress calEntry nBytes)) + && alignment + == 0 wishboneAddress = bitCoerce $ resize alignedAddress wishboneActive = busCycle && strobe - wishboneError = wishboneActive && not wbAddrValid + wishboneError = wishboneActive && not wbAddrValid wbWriting = wishboneActive && writeEnable && not wishboneError wbNewCalEntry = wbWriting && wishboneAddress < calEntryRegs @@ -373,22 +420,25 @@ wbCalRX = case oneLeCLog2n @calDepth of shadowReadAddr = getDataLe @(nBytes * 8) calStReadAddr shadowEntryData = getDataLe @(nBytes * 8) calStRegisters - wbState1 = wbState - { calStRegisters = newPartialCalEntry - , calStReadAddr = newShadowReadAddr} + wbState1 = + wbState + { calStRegisters = newPartialCalEntry + , calStReadAddr = newShadowReadAddr + } newPartialCalEntry | wbNewCalEntry = updateRegisters wishboneAddress calStRegisters - | otherwise = calStRegisters + | otherwise = calStRegisters newShadowReadAddr | wbNewShadowReadAddr = updateRegisters (0 :: Int) calStReadAddr - | otherwise = calStReadAddr + | otherwise = calStReadAddr - updateRegisters :: forall i a. + updateRegisters :: + forall i a. (Enum i, KnownNat (BitSize a)) => i -> - RegisterBank (nBytes*8) a 'LittleEndian -> - RegisterBank (nBytes*8) a 'LittleEndian + RegisterBank (nBytes * 8) a 'LittleEndian -> + RegisterBank (nBytes * 8) a 'LittleEndian updateRegisters i = updateRegBank i busSelect writeData calAddr = bitCoerce $ resize writeData @@ -396,77 +446,87 @@ wbCalRX = case oneLeCLog2n @calDepth of newShadowDepth = orNothing wbNewShadowDepth calAddr newShadowEntry = orNothing wbNewShadowWriteAddr (calAddr, shadowEntryData) - calControl = CalendarControl - { newShadowDepth - , newShadowEntry - , shadowReadAddr - , wishboneActive - , wishboneError - , wishboneAddress - , armCalendarSwap - } - --- | Wishbone interface that drives the outgoing wishbone data based on the received --- wishbone address. Can be used to read one of the following registers: --- * The shadow calendar entry register --- * The shadow calendar read address register --- * The shadow calendar depth register + calControl = + CalendarControl + { newShadowDepth + , newShadowEntry + , shadowReadAddr + , wishboneActive + , wishboneError + , wishboneAddress + , armCalendarSwap + } + +{- | Wishbone interface that drives the outgoing wishbone data based on the received +wishbone address. Can be used to read one of the following registers: + * The shadow calendar entry register + * The shadow calendar read address register + * The shadow calendar depth register +-} wbCalTX :: - forall calDepth calEntry nBytes . + forall calDepth calEntry nBytes. ( Paddable (Index calDepth) - , Paddable calEntry, Show calEntry - , KnownNat nBytes, 1 <= nBytes) => - CalendarControl calDepth calEntry nBytes-> + , Paddable calEntry + , Show calEntry + , KnownNat nBytes + , 1 <= nBytes + ) => + CalendarControl calDepth calEntry nBytes -> CalendarOutput calDepth calEntry -> WishboneS2M (Bytes nBytes) -wbCalTX CalendarControl{shadowReadAddr, wishboneActive, wishboneError, wishboneAddress} - CalendarOutput{shadowEntry, shadowDepth} = wbOut - where - readData = - case (getRegsLe shadowEntry, getRegsLe shadowReadAddr, getRegsLe shadowDepth) of - (RegisterBank entryVec, RegisterBank readAddrVec, RegisterBank depthVec) -> - ((entryVec :< 0b0) ++ readAddrVec ++ depthVec) !! wishboneAddress - wbOut = (emptyWishboneS2M @(Bytes nBytes)) - { acknowledge = wishboneActive - , err = wishboneError - , readData - } +wbCalTX + CalendarControl{shadowReadAddr, wishboneActive, wishboneError, wishboneAddress} + CalendarOutput{shadowEntry, shadowDepth} = wbOut + where + readData = + case (getRegsLe shadowEntry, getRegsLe shadowReadAddr, getRegsLe shadowDepth) of + (RegisterBank entryVec, RegisterBank readAddrVec, RegisterBank depthVec) -> + ((entryVec :< 0b0) ++ readAddrVec ++ depthVec) !! wishboneAddress + wbOut = + (emptyWishboneS2M @(Bytes nBytes)) + { acknowledge = wishboneActive + , err = wishboneError + , readData + } updateRegBank :: ( Enum i , KnownNat nBytes , 1 <= nBytes - , KnownNat (BitSize a)) => + , KnownNat (BitSize a) + ) => i -> BitVector nBytes -> Bytes nBytes -> - RegisterBank (nBytes * 8) a 'LittleEndian-> + RegisterBank (nBytes * 8) a 'LittleEndian -> RegisterBank (nBytes * 8) a 'LittleEndian updateRegBank i byteSelect newBV (RegisterBank vec) = RegisterBank newVec where newVec = replace i (regUpdate byteSelect (vec !! i) newBV) vec regUpdate :: - KnownNat nBytes => - BitVector nBytes-> + (KnownNat nBytes) => + BitVector nBytes -> Bytes nBytes -> Bytes nBytes -> Bytes nBytes regUpdate byteEnable oldEntry newEntry = - bitCoerce $ (\e (o, n :: BitVector 8) -> if e then n else o) <$> - bitCoerce byteEnable <*> zip (bitCoerce oldEntry) (bitCoerce newEntry) + bitCoerce + $ (\e (o, n :: BitVector 8) -> if e then n else o) + <$> bitCoerce byteEnable + <*> zip (bitCoerce oldEntry) (bitCoerce newEntry) type WbAddress calEntry nBytes = Index (Regs calEntry (nBytes * 8) + ExtraRegs) type ExtraRegs = 4 -shadowWriteWbAddr :: forall n . (KnownNat n, 4 <=n) => Index n +shadowWriteWbAddr :: forall n. (KnownNat n, 4 <= n) => Index n shadowWriteWbAddr = natToNum @(n - 4) -shadowReadWbAddr :: forall n . (KnownNat n, 3 <= n) => Index n +shadowReadWbAddr :: forall n. (KnownNat n, 3 <= n) => Index n shadowReadWbAddr = natToNum @(n - 3) -shadowDepthWbAddr :: forall n . (KnownNat n, 2 <= n) => Index n +shadowDepthWbAddr :: forall n. (KnownNat n, 2 <= n) => Index n shadowDepthWbAddr = natToNum @(n - 2) -calSwapWbAddr :: forall n . (KnownNat n, 1 <= n) => Index n +calSwapWbAddr :: forall n. (KnownNat n, 1 <= n) => Index n calSwapWbAddr = natToNum @(n - 1) diff --git a/bittide/src/Bittide/ClockControl.hs b/bittide/src/Bittide/ClockControl.hs index 6e553a464..061e01759 100644 --- a/bittide/src/Bittide/ClockControl.hs +++ b/bittide/src/Bittide/ClockControl.hs @@ -1,34 +1,33 @@ +{-# LANGUAGE NamedFieldPuns #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans -fconstraint-solver-iterations=10 #-} -- | Clock controller types and some constants/defaults. -module Bittide.ClockControl - ( ClockControlConfig (..) - , RelDataCount - , SettlePeriod - , SpeedChange (..) - , defClockConfig - , pessimisticSettleCycles - , targetDataCount - , clockPeriodFs - , speedChangeToFincFdec - , sign - ) +module Bittide.ClockControl ( + ClockControlConfig (..), + RelDataCount, + SettlePeriod, + SpeedChange (..), + defClockConfig, + pessimisticSettleCycles, + targetDataCount, + clockPeriodFs, + speedChangeToFincFdec, + sign, +) where -import Clash.Explicit.Prelude hiding (PeriodToCycles) -import Clash.Signal.Internal (Femtoseconds(..)) -import Data.Aeson (ToJSON(toJSON)) -import Data.Proxy (Proxy(..)) +import Clash.Explicit.Prelude hiding (PeriodToCycles) +import Clash.Signal.Internal (Femtoseconds (..)) +import Data.Aeson (ToJSON (toJSON)) +import Data.Proxy (Proxy (..)) import Foreign.C.Types (CUInt) import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (Storable(..)) +import Foreign.Storable (Storable (..)) import GHC.Stack (HasCallStack) import Bittide.Arithmetic.Ppm @@ -41,86 +40,74 @@ type SettlePeriod = Femtoseconds -- | Configuration passed to 'clockControl' data ClockControlConfig dom n m c = ClockControlConfig - { -- | The quickest a clock could possibly run at. Used to (pessimistically) - -- estimate when a new command can be issued. - -- - -- TODO: Should be removed, it follows from other fields + domain. - -- - cccPessimisticPeriod :: Femtoseconds - - -- | Like 'cccPessimisticPeriod', but expressed as number of cycles. - -- - -- TODO: Should be removed, it follows from other fields + domain. - -- + { cccPessimisticPeriod :: Femtoseconds + -- ^ The quickest a clock could possibly run at. Used to (pessimistically) + -- estimate when a new command can be issued. + -- + -- TODO: Should be removed, it follows from other fields + domain. , cccPessimisticSettleCycles :: Unsigned 32 - - -- | Period it takes for a clock frequency request to settle. This is not - -- modelled, but an error is thrown if a request is submitted more often than - -- this. 'clockControl' should therefore not request changes more often. - -- - -- This is a PLL property. - -- + -- ^ Like 'cccPessimisticPeriod', but expressed as number of cycles. + -- + -- TODO: Should be removed, it follows from other fields + domain. , cccSettlePeriod :: Femtoseconds - - -- | Maximum deviation from "factory tuning". E.g., a clock tuned to 200 MHz - -- and a maximum deviation of +- 100 ppm can produce a signal anywhere - -- between 200 MHz +- 20 KHz. - -- - -- This is an oscillator + PLL property. - -- + -- ^ Period it takes for a clock frequency request to settle. This is not + -- modelled, but an error is thrown if a request is submitted more often than + -- this. 'clockControl' should therefore not request changes more often. + -- + -- This is a PLL property. , cccDeviation :: Ppm - - -- | Step size for frequency increments / decrements - -- - -- This is a setting of the PLL. Note that though this is a setting, it is - -- programmed over I2C. For the time being, we expect it to be programmed - -- once after which only the FDEC/FINC pins will be used. - -- - -- TODO: Should be expressed as PPM. - -- + -- ^ Maximum deviation from "factory tuning". E.g., a clock tuned to 200 MHz + -- and a maximum deviation of +- 100 ppm can produce a signal anywhere + -- between 200 MHz +- 20 KHz. + -- + -- This is an oscillator + PLL property. , cccStepSize :: Femtoseconds - - -- | Size of elastic buffers. Used to observe bounds and 'targetDataCount'. + -- ^ Step size for frequency increments / decrements + -- + -- This is a setting of the PLL. Note that though this is a setting, it is + -- programmed over I2C. For the time being, we expect it to be programmed + -- once after which only the FDEC/FINC pins will be used. + -- + -- TODO: Should be expressed as PPM. , cccBufferSize :: SNat n - - -- | Bound on the number of elements the elastic buffer is allowed - -- to deviate from while still being considered "stable". + -- ^ Size of elastic buffers. Used to observe bounds and 'targetDataCount'. , cccStabilityCheckerMargin :: SNat m - - -- | The minimum number of clock cycles an elastic buffer must - -- remain within the @cccStabilityCheckerMargin@ to be considered - -- "stable". + -- ^ Bound on the number of elements the elastic buffer is allowed + -- to deviate from while still being considered "stable". , cccStabilityCheckerFramesize :: SNat c - - -- | Enable reframing. Reframing allows a system to resettle buffers around - -- their midpoints, without dropping any frames. For more information, see - -- [arXiv:2303.11467](https://arxiv.org/abs/2303.11467). + -- ^ The minimum number of clock cycles an elastic buffer must + -- remain within the @cccStabilityCheckerMargin@ to be considered + -- "stable". , cccEnableReframing :: Bool - - -- | Number of pessimistic settle cycles to wait until reframing - -- takes place after stability has been detected, as it is used by - -- the "detect, store, and wait" reframing approach + -- ^ Enable reframing. Reframing allows a system to resettle buffers around + -- their midpoints, without dropping any frames. For more information, see + -- [arXiv:2303.11467](https://arxiv.org/abs/2303.11467). , cccReframingWaitTime :: Unsigned 32 - - -- | If set, then the clock control algorithm is simulated via the Rust FFI. + -- ^ Number of pessimistic settle cycles to wait until reframing + -- takes place after stability has been detected, as it is used by + -- the "detect, store, and wait" reframing approach , cccEnableRustySimulation :: Bool - } deriving (Lift) + -- ^ If set, then the clock control algorithm is simulated via the Rust FFI. + } + deriving (Lift) --- | The (virtual) type of the FIFO's data counter. Setting this to --- 'Unsigned' captures the real implementation of the FIFO, while --- setting it to 'Signed' results in a virtual correction shifting the --- FIFO's center to be always at @0@. --- --- _(remember to also modify 'targetDataCount' below if the --- representation of 'RelDataCount' gets changed.)_ +{- | The (virtual) type of the FIFO's data counter. Setting this to +'Unsigned' captures the real implementation of the FIFO, while +setting it to 'Signed' results in a virtual correction shifting the +FIFO's center to be always at @0@. + +_(remember to also modify 'targetDataCount' below if the +representation of 'RelDataCount' gets changed.)_ +-} type RelDataCount n = Signed n --- | The target data count within a (virtual) FIFO. It is usually set --- to be at the FIFO's center. --- --- _(recommended values are @0@ if 'RelDataCount' is 'Signed' and @shiftR --- maxBound 1 + 1@ if it is 'Unsigned')_ -targetDataCount :: KnownNat n => RelDataCount n +{- | The target data count within a (virtual) FIFO. It is usually set +to be at the FIFO's center. + +_(recommended values are @0@ if 'RelDataCount' is 'Signed' and @shiftR +maxBound 1 + 1@ if it is 'Unsigned')_ +-} +targetDataCount :: (KnownNat n) => RelDataCount n targetDataCount = 0 -- | Safer version of FINC/FDEC signals present on the Si5395/Si5391 clock multipliers. @@ -130,14 +117,18 @@ data SpeedChange | SpeedUp deriving (Eq, Show, Generic, BitPack, ShowX, NFDataX) -type instance SizeOf SpeedChange = - SizeOf CUInt +type instance + SizeOf SpeedChange = + SizeOf CUInt -type instance Alignment SpeedChange = - Alignment CUInt +type instance + Alignment SpeedChange = + Alignment CUInt -instance (SizeOf SpeedChange ~ 4, Alignment SpeedChange ~ 4) - => Storable SpeedChange where +instance + (SizeOf SpeedChange ~ 4, Alignment SpeedChange ~ 4) => + Storable SpeedChange + where sizeOf = const $ natToNum @(SizeOf SpeedChange) alignment = const $ natToNum @(Alignment SpeedChange) @@ -154,13 +145,14 @@ instance (SizeOf SpeedChange ~ 4, Alignment SpeedChange ~ 4) to = \case NoChange -> 0 SlowDown -> 1 - SpeedUp -> 2 + SpeedUp -> 2 --- | Converts speed changes into a normalized scalar, which reflects --- their effect on clock control. -sign :: Num a => SpeedChange -> a +{- | Converts speed changes into a normalized scalar, which reflects +their effect on clock control. +-} +sign :: (Num a) => SpeedChange -> a sign = \case - SpeedUp -> 1 + SpeedUp -> 1 NoChange -> 0 SlowDown -> -1 @@ -170,16 +162,17 @@ data ToFincFdecState dom | Idle deriving (Generic, NFDataX) --- | Convert 'SpeedChange' to a pair of (FINC, FDEC). This is currently hardcoded --- to work on the Si5395 constraints: --- --- * Minimum Pulse Width: 100 ns --- * Update Rate: 1 us --- --- TODO: De-hardcode +{- | Convert 'SpeedChange' to a pair of (FINC, FDEC). This is currently hardcoded +to work on the Si5395 constraints: + + * Minimum Pulse Width: 100 ns + * Update Rate: 1 us + +TODO: De-hardcode +-} speedChangeToFincFdec :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => Clock dom -> Reset dom -> Signal dom SpeedChange -> @@ -189,19 +182,17 @@ speedChangeToFincFdec clk rst = where go :: ToFincFdecState dom -> SpeedChange -> (ToFincFdecState dom, SpeedChange) go (Wait n) _s - | n == 0 = (Idle, NoChange) + | n == 0 = (Idle, NoChange) | otherwise = (Wait (n - 1), NoChange) - go (Pulse n s) _s - | n == 0 = (Wait maxBound, s) + | n == 0 = (Wait maxBound, s) | otherwise = (Pulse (n - 1) s, s) - go Idle NoChange = (Idle, NoChange) - go Idle s = (Pulse maxBound s, NoChange) + go Idle s = (Pulse maxBound s, NoChange) -- FINC FDEC conv NoChange = (False, False) - conv SpeedUp = (True, False) + conv SpeedUp = (True, False) conv SlowDown = (False, True) instance ToField SpeedChange where @@ -209,16 +200,16 @@ instance ToField SpeedChange where toField SlowDown = "slowDown" toField NoChange = "noChange" -instance KnownNat n => ToField (Unsigned n) where +instance (KnownNat n) => ToField (Unsigned n) where toField = toField . toInteger -instance KnownNat n => ToJSON (Unsigned n) where +instance (KnownNat n) => ToJSON (Unsigned n) where toJSON = toJSON . toInteger -instance KnownNat n => ToField (Signed n) where +instance (KnownNat n) => ToField (Signed n) where toField = toField . toInteger -instance KnownNat n => ToJSON (Signed n) where +instance (KnownNat n) => ToJSON (Signed n) where toJSON = toJSON . toInteger instance ToField Femtoseconds where @@ -227,37 +218,39 @@ instance ToField Femtoseconds where instance ToJSON Femtoseconds where toJSON (Femtoseconds fs) = toJSON fs -clockPeriodFs :: forall dom. KnownDomain dom => Proxy dom -> Femtoseconds +clockPeriodFs :: forall dom. (KnownDomain dom) => Proxy dom -> Femtoseconds clockPeriodFs Proxy = Femtoseconds (1000 * snatToNum (clockPeriod @dom)) -defClockConfig :: forall dom. KnownDomain dom => ClockControlConfig dom 12 8 1500000 -defClockConfig = ClockControlConfig - { cccPessimisticPeriod = pessimisticPeriod - , cccPessimisticSettleCycles = pessimisticSettleCycles self - , cccSettlePeriod = microseconds 1 - , cccStepSize = stepSize - , cccBufferSize = d12 -- 2**12 ~ 4096 - , cccDeviation = Ppm 100 - , cccStabilityCheckerMargin = SNat - , cccStabilityCheckerFramesize = SNat - , cccEnableReframing = True - , cccReframingWaitTime = 160000 - , cccEnableRustySimulation = False - } +defClockConfig :: forall dom. (KnownDomain dom) => ClockControlConfig dom 12 8 1500000 +defClockConfig = + ClockControlConfig + { cccPessimisticPeriod = pessimisticPeriod + , cccPessimisticSettleCycles = pessimisticSettleCycles self + , cccSettlePeriod = microseconds 1 + , cccStepSize = stepSize + , cccBufferSize = d12 -- 2**12 ~ 4096 + , cccDeviation = Ppm 100 + , cccStabilityCheckerMargin = SNat + , cccStabilityCheckerFramesize = SNat + , cccEnableReframing = True + , cccReframingWaitTime = 160000 + , cccEnableRustySimulation = False + } where self = defClockConfig @dom stepSize = diffPeriod (Ppm 1) (clockPeriodFs @dom Proxy) pessimisticPeriod = adjustPeriod (cccDeviation self) (clockPeriodFs @dom Proxy) --- | Number of cycles to wait on a given clock frequency and clock settings in --- order for the settle period to pass. /Pessimistic/ means that it calculates --- this for the fastest possible clock. --- +{- | Number of cycles to wait on a given clock frequency and clock settings in +order for the settle period to pass. /Pessimistic/ means that it calculates +this for the fastest possible clock. +-} pessimisticSettleCycles :: forall dom n m c. ( HasCallStack - , KnownDomain dom ) => - ClockControlConfig dom n m c-> + , KnownDomain dom + ) => + ClockControlConfig dom n m c -> -- | It would take a 10 GHz clock only a 10_000 cycles to wait 1 µs. This can be -- met by an @Unsigned 14@: @2^14 ~ 16384@. To massively overkill it we bump it -- up to 32 bits. diff --git a/bittide/src/Bittide/ClockControl/Callisto.hs b/bittide/src/Bittide/ClockControl/Callisto.hs index 59a277048..e6705eb79 100644 --- a/bittide/src/Bittide/ClockControl/Callisto.hs +++ b/bittide/src/Bittide/ClockControl/Callisto.hs @@ -1,14 +1,13 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE RecordWildCards #-} -module Bittide.ClockControl.Callisto - ( CallistoResult(..) - , ReframingState(..) - , callistoClockControl - ) where +module Bittide.ClockControl.Callisto ( + CallistoResult (..), + ReframingState (..), + callistoClockControl, +) where import Clash.Prelude @@ -17,8 +16,8 @@ import Data.Constraint.Nat (leTrans) import Data.Constraint.Nat.Extra (euclid3, useLowerLimit) import Bittide.ClockControl -import Bittide.ClockControl.Callisto.Util import Bittide.ClockControl.Callisto.Types +import Bittide.ClockControl.Callisto.Util import Bittide.ClockControl.Foreign.Rust.Callisto import Bittide.ClockControl.StabilityChecker import Bittide.Extra.Maybe @@ -27,8 +26,10 @@ import qualified Clash.Cores.Xilinx.Floating as F import qualified Clash.Signal.Delayed as D {-# NOINLINE callistoClockControl #-} --- | Determines how to influence clock frequency given statistics provided by --- all elastic buffers. See 'callisto' for more information. + +{- | Determines how to influence clock frequency given statistics provided by +all elastic buffers. See 'callisto' for more information. +-} callistoClockControl :: forall n m dom margin framesize. ( KnownDomain dom @@ -52,36 +53,38 @@ callistoClockControl :: Vec n (Signal dom (RelDataCount m)) -> Signal dom (CallistoResult n) callistoClockControl clk rst ena ClockControlConfig{..} mask allDataCounts = - withClockResetEnable clk rst ena $ - let - dataCounts = filterCounts <$> fmap bv2v mask <*> bundle allDataCounts - updateCounter = wrappingCounter cccPessimisticSettleCycles - shouldUpdate = updateCounter .==. 0 - scs = bundle $ map stabilityCheck $ unbundle dataCounts - allStable = allAvailable stable <$> mask <*> scs - allSettled = allAvailable settled <$> mask <*> scs - state = register initState state' - - clockControl = - if cccEnableRustySimulation - then rustyCallisto - else callisto - - state' = mux shouldUpdate - (clockControl controlConfig mask scs dataCounts state) - state - - stabilityCheck = stabilityChecker - cccStabilityCheckerMargin - cccStabilityCheckerFramesize - in - CallistoResult - <$> (orNothing <$> shouldUpdate <*> fmap _b_k state') - <*> scs - <*> allStable - <*> allSettled - <*> (rfState <$> state') - + withClockResetEnable clk rst ena + $ let + dataCounts = filterCounts <$> fmap bv2v mask <*> bundle allDataCounts + updateCounter = wrappingCounter cccPessimisticSettleCycles + shouldUpdate = updateCounter .==. 0 + scs = bundle $ map stabilityCheck $ unbundle dataCounts + allStable = allAvailable stable <$> mask <*> scs + allSettled = allAvailable settled <$> mask <*> scs + state = register initState state' + + clockControl = + if cccEnableRustySimulation + then rustyCallisto + else callisto + + state' = + mux + shouldUpdate + (clockControl controlConfig mask scs dataCounts state) + state + + stabilityCheck = + stabilityChecker + cccStabilityCheckerMargin + cccStabilityCheckerFramesize + in + CallistoResult + <$> (orNothing <$> shouldUpdate <*> fmap _b_k state') + <*> scs + <*> allStable + <*> allSettled + <*> (rfState <$> state') where controlConfig = ControlConfig @@ -98,24 +101,25 @@ callistoClockControl clk rst ena ClockControlConfig{..} mask allDataCounts = , rfState = Detect } - filterCounts vMask vCounts = flip map (zip vMask vCounts) $ - \(isActive, count) -> if isActive == high then count else 0 + filterCounts vMask vCounts = flip map (zip vMask vCounts) + $ \(isActive, count) -> if isActive == high then count else 0 allAvailable f x y = and $ zipWith ((||) . not) (bitToBool <$> bv2v x) (f <$> y) --- | Clock correction strategy based on: --- --- https://github.com/bittide/Callisto.jl --- --- Note that this is an incredibly wasteful implementation: it instantiates --- numerous floating point multipliers and adders, even though they're not doing --- any useful work 99% of the time. Furthermore, 'RelDataCount' isn't properly --- scaled to match elastic buffer sizes, resulting in unnecessarily big integer --- adders. Optimization work has been postponed because: --- --- * It isn't clear yet whether this will be the final clock control algorithm. --- * These algorithms will probably run on a Risc core in the future. +{- | Clock correction strategy based on: + + https://github.com/bittide/Callisto.jl + +Note that this is an incredibly wasteful implementation: it instantiates +numerous floating point multipliers and adders, even though they're not doing +any useful work 99% of the time. Furthermore, 'RelDataCount' isn't properly +scaled to match elastic buffer sizes, resulting in unnecessarily big integer +adders. Optimization work has been postponed because: + + * It isn't clear yet whether this will be the final clock control algorithm. + * These algorithms will probably run on a Risc core in the future. +-} callisto :: forall m n dom. ( HiddenClockResetEnable dom @@ -123,10 +127,10 @@ callisto :: , KnownNat m , 1 <= n , 1 <= m - -- 'callisto' sums incoming 'RelDataCount's and feeds them to a Xilinx signed to - -- float IP. We can currently only interpret 32 bit signeds to unsigned, so to - -- make sure we don't overflow any addition we force @n + m <= 32@. - , n + m <= 32 + , -- 'callisto' sums incoming 'RelDataCount's and feeds them to a Xilinx signed to + -- float IP. We can currently only interpret 32 bit signeds to unsigned, so to + -- make sure we don't overflow any addition we force @n + m <= 32@. + n + m <= 32 ) => -- | Configuration parameters. ControlConfig m -> @@ -146,11 +150,13 @@ callisto ControlConfig{..} mask scs dataCounts state = <*> D.toSignal c_des <*> updatedState where - updatedState = D.toSignal $ ControlSt - <$> delayIU "[1]" z_kNext - <*> b_kNext - <*> delayIU "[2]" steadyStateTarget - <*> delayIU "[3]" (D.fromSignal (rfState <$> state)) + updatedState = + D.toSignal + $ ControlSt + <$> delayIU "[1]" z_kNext + <*> b_kNext + <*> delayIU "[2]" steadyStateTarget + <*> delayIU "[3]" (D.fromSignal (rfState <$> state)) -- See fields in 'ControlSt' for documentation of 'z_k', 'b_k', and css. z_k :: DSignal dom 0 (Signed 32) @@ -171,16 +177,18 @@ callisto ControlConfig{..} mask scs dataCounts state = fStep = pure 5e-4 r_k :: DSignal dom F.FromS32DefDelay Float - r_k = F.fromS32 $ D.fromSignal $ - let - nBuffers = case useLowerLimit @n @m @32 of - Dict -> safePopCountTo32 <$> mask - measuredSum = sumTo32 <$> dataCounts - targetCountSigned = case euclid3 @n @m @32 of - Dict -> case leTrans @1 @n @(32 - m) of - Sub Dict -> extend @_ @_ @(32 - m - 1) $ dataCountToSigned targetCount - in - measuredSum - (pure targetCountSigned * nBuffers) + r_k = + F.fromS32 + $ D.fromSignal + $ let + nBuffers = case useLowerLimit @n @m @32 of + Dict -> safePopCountTo32 <$> mask + measuredSum = sumTo32 <$> dataCounts + targetCountSigned = case euclid3 @n @m @32 of + Dict -> case leTrans @1 @n @(32 - m) of + Sub Dict -> extend @_ @_ @(32 - m - 1) $ dataCountToSigned targetCount + in + measuredSum - (pure targetCountSigned * nBuffers) c_des :: DSignal dom (F.FromS32DefDelay + F.MulDefDelay + F.AddDefDelay) Float c_des = delayIU "[4]" $ (k_p `F.mul` r_k) `F.add` delayIU "[5]" steadyStateTarget @@ -206,28 +214,35 @@ callisto ControlConfig{..} mask scs dataCounts state = | not stable -> st | otherwise -> - st { rfState = Wait - { curWaitTime = waitTime - , targetCorrection = target - } - } + st + { rfState = + Wait + { curWaitTime = waitTime + , targetCorrection = target + } + } Wait{..} | curWaitTime > 0 -> - st { rfState = Wait - { curWaitTime = curWaitTime - 1 - , .. - } - } + st + { rfState = + Wait + { curWaitTime = curWaitTime - 1 + , .. + } + } | otherwise -> - st { rfState = Done - , _steadyStateTarget = targetCorrection - } + st + { rfState = Done + , _steadyStateTarget = targetCorrection + } Done -> st -- Uninitialized version of 'Clash.Signal.Delayed.delayI' delayIU :: forall d k a. (HiddenClock dom, HiddenEnable dom, NFDataX a, KnownNat d) => - String -> DSignal dom k a -> DSignal dom (k + d) a + String -> + DSignal dom k a -> + DSignal dom (k + d) a delayIU = D.delayI . errorX . ("callisto: No start value " <>) diff --git a/bittide/src/Bittide/ClockControl/Callisto/Types.hs b/bittide/src/Bittide/ClockControl/Callisto/Types.hs index bffacbeed..8e30794c0 100644 --- a/bittide/src/Bittide/ClockControl/Callisto/Types.hs +++ b/bittide/src/Bittide/ClockControl/Callisto/Types.hs @@ -1,164 +1,176 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -module Bittide.ClockControl.Callisto.Types - ( CallistoResult(..) - , ReframingState(..) - , ControlConfig(..) - , ControlSt(..) - , RelDataCountS(..) - , VecS(..) - , BitsOf - ) where +module Bittide.ClockControl.Callisto.Types ( + CallistoResult (..), + ReframingState (..), + ControlConfig (..), + ControlSt (..), + RelDataCountS (..), + VecS (..), + BitsOf, +) where import Clash.Prelude -import Foreign.Storable (Storable(..)) -import Foreign.C.Types (CUInt, CInt) +import Foreign.C.Types (CInt, CUInt) import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable (..)) import Bittide.ClockControl -import Bittide.ClockControl.StabilityChecker (StabilityIndication) import Bittide.ClockControl.Foreign.Sizes +import Bittide.ClockControl.StabilityChecker (StabilityIndication) import Data.Constraint import Data.Constraint.Nat.Extra (OneMore, oneMore) -- | Result of the clock control algorithm. -data CallistoResult (n :: Nat) = - CallistoResult - { maybeSpeedChange :: Maybe SpeedChange - -- ^ Speed change requested for clock multiplier. This is 'Just' for a single - -- cycle. - , stability :: Vec n StabilityIndication - -- ^ All stability indicators for all of the elastic buffers. - , allStable :: Bool - -- ^ Joint stability indicator signaling that all elastic buffers - -- are stable. - , allSettled :: Bool - -- ^ Joint "being-settled" indicator signaling that all elastic - -- buffers have been settled. - , reframingState :: ReframingState - -- ^ State of the Reframing detector - } +data CallistoResult (n :: Nat) = CallistoResult + { maybeSpeedChange :: Maybe SpeedChange + -- ^ Speed change requested for clock multiplier. This is 'Just' for a single + -- cycle. + , stability :: Vec n StabilityIndication + -- ^ All stability indicators for all of the elastic buffers. + , allStable :: Bool + -- ^ Joint stability indicator signaling that all elastic buffers + -- are stable. + , allSettled :: Bool + -- ^ Joint "being-settled" indicator signaling that all elastic + -- buffers have been settled. + , reframingState :: ReframingState + -- ^ State of the Reframing detector + } deriving (Generic, NFDataX) -- | Callisto specific control configuration options. -data ControlConfig (m :: Nat) = - ControlConfig - { reframingEnabled :: Bool - -- ^ Enable reframing. Reframing allows a system to resettle buffers around - -- their midpoints, without dropping any frames. For more information, see - -- [arXiv:2303.11467](https://arxiv.org/abs/2303.11467). - , waitTime :: Unsigned 32 - -- ^ Number of cycles to wait until reframing takes place after - -- stability has been detected. - , targetCount :: RelDataCount m - -- ^ Target data count. See 'targetDataCount'. - } - -type instance SizeOf (ControlConfig m) = - SizeOf Int + SizeOf Int + SizeOf (RelDataCountS m) - -type instance Alignment (ControlConfig m) = - Alignment (RelDataCountS m) +data ControlConfig (m :: Nat) = ControlConfig + { reframingEnabled :: Bool + -- ^ Enable reframing. Reframing allows a system to resettle buffers around + -- their midpoints, without dropping any frames. For more information, see + -- [arXiv:2303.11467](https://arxiv.org/abs/2303.11467). + , waitTime :: Unsigned 32 + -- ^ Number of cycles to wait until reframing takes place after + -- stability has been detected. + , targetCount :: RelDataCount m + -- ^ Target data count. See 'targetDataCount'. + } + +type instance + SizeOf (ControlConfig m) = + SizeOf Int + SizeOf Int + SizeOf (RelDataCountS m) + +type instance + Alignment (ControlConfig m) = + Alignment (RelDataCountS m) instance ( KnownNat m , SizeOf (ControlConfig m) ~ 3 * SizeOf Int , Alignment (ControlConfig m) ~ Alignment Int - ) - => Storable (ControlConfig m) where + ) => + Storable (ControlConfig m) + where sizeOf = const $ natToNum @(SizeOf (ControlConfig m)) alignment = const $ natToNum @(Alignment (ControlConfig m)) - peek p = let s = natToNum @(SizeOf Int) in - ControlConfig - <$> ((/= 0) <$> (peekByteOff p 0 :: IO Int)) - <*> (fromInteger . toInteger <$> (peekByteOff p s :: IO Int)) - <*> (fromInteger . toInteger <$> (peekByteOff p (2*s) :: IO Int)) + peek p = + let s = natToNum @(SizeOf Int) + in ControlConfig + <$> ((/= 0) <$> (peekByteOff p 0 :: IO Int)) + <*> (fromInteger . toInteger <$> (peekByteOff p s :: IO Int)) + <*> (fromInteger . toInteger <$> (peekByteOff p (2 * s) :: IO Int)) poke p ControlConfig{..} = do let s = natToNum @(SizeOf Int) pokeByteOff p 0 ((toEnum $ fromEnum reframingEnabled) :: Int) pokeByteOff p s ((fromInteger $ toInteger waitTime) :: Int) - pokeByteOff p (2*s) ((fromInteger $ toInteger targetCount) :: Int) + pokeByteOff p (2 * s) ((fromInteger $ toInteger targetCount) :: Int) --- | State of the state machine for realizing the "detect, store, and --- wait" approach of [arXiv:2303.11467](https://arxiv.org/abs/2303.11467) -data ReframingState = - Detect - -- ^ The controller remains in this state until stability has been +{- | State of the state machine for realizing the "detect, store, and +wait" approach of [arXiv:2303.11467](https://arxiv.org/abs/2303.11467) +-} +data ReframingState + = -- | The controller remains in this state until stability has been -- detected. - | Wait - -- ^ The controller remains in this state for the predefined + Detect + | -- | The controller remains in this state for the predefined -- number of cycles with the assumption that the elastic buffers -- of all other nodes are sufficiently stable after that time. + Wait { targetCorrection :: !Float -- ^ Stored correction value to be applied at reframing time. , curWaitTime :: !(Unsigned 32) -- ^ Number of cycles to wait until reframing takes place. } - | Done - -- ^ Reframing has taken place. There is nothing more to do. + | -- | Reframing has taken place. There is nothing more to do. + Done deriving (Generic, NFDataX) -type instance SizeOf ReframingState = - SizeOf CUInt + SizeOf Float + SizeOf CUInt +type instance + SizeOf ReframingState = + SizeOf CUInt + SizeOf Float + SizeOf CUInt -type instance Alignment ReframingState = - Alignment CUInt +type instance + Alignment ReframingState = + Alignment CUInt -instance (SizeOf ReframingState ~ 12, Alignment ReframingState ~ 4) - => Storable ReframingState where +instance + (SizeOf ReframingState ~ 12, Alignment ReframingState ~ 4) => + Storable ReframingState + where sizeOf = const $ natToNum @(SizeOf ReframingState) alignment = const $ natToNum @(Alignment ReframingState) - peek p = (peekByteOff p 0 :: IO CUInt) >>= \case - 0 -> return Detect - 1 -> return Done - 2 -> Wait <$> peekByteOff p 4 - <*> ((fromIntegral :: CUInt -> Unsigned 32) <$> peekByteOff p 8) - _ -> error "out of range" + peek p = + (peekByteOff p 0 :: IO CUInt) >>= \case + 0 -> return Detect + 1 -> return Done + 2 -> + Wait + <$> peekByteOff p 4 + <*> ((fromIntegral :: CUInt -> Unsigned 32) <$> peekByteOff p 8) + _ -> error "out of range" poke p = \case - Detect -> pokeByteOff p 0 (0 :: CUInt) - Done -> pokeByteOff p 0 (1 :: CUInt) + Detect -> pokeByteOff p 0 (0 :: CUInt) + Done -> pokeByteOff p 0 (1 :: CUInt) Wait{..} -> do pokeByteOff p 0 (2 :: CUInt) pokeByteOff p 4 targetCorrection pokeByteOff p 8 (fromIntegral curWaitTime :: CUInt) -- | Callisto's internal state used in 'callisto' -data ControlSt = - ControlSt - { _z_k :: !(Signed 32) - -- ^ Accumulated speed change requests, where speedup ~ 1, slowdown ~ -1. - , _b_k :: !SpeedChange - -- ^ Previously submitted speed change request. Used to determine the estimated - -- clock frequency. - , _steadyStateTarget :: !Float - -- ^ Steady-state value (determined when stability is detected for - -- the first time). - , rfState :: !ReframingState - -- ^ finite state machine for reframing detection - } +data ControlSt = ControlSt + { _z_k :: !(Signed 32) + -- ^ Accumulated speed change requests, where speedup ~ 1, slowdown ~ -1. + , _b_k :: !SpeedChange + -- ^ Previously submitted speed change request. Used to determine the estimated + -- clock frequency. + , _steadyStateTarget :: !Float + -- ^ Steady-state value (determined when stability is detected for + -- the first time). + , rfState :: !ReframingState + -- ^ finite state machine for reframing detection + } deriving (Generic, NFDataX) -type instance SizeOf ControlSt = - SizeOf CInt + SizeOf SpeedChange + SizeOf Float + SizeOf ReframingState +type instance + SizeOf ControlSt = + SizeOf CInt + SizeOf SpeedChange + SizeOf Float + SizeOf ReframingState -type instance Alignment ControlSt = - Alignment CInt +type instance + Alignment ControlSt = + Alignment CInt -instance (SizeOf ControlSt ~ 24, Alignment ControlSt ~ 4) - => Storable ControlSt where +instance + (SizeOf ControlSt ~ 24, Alignment ControlSt ~ 4) => + Storable ControlSt + where sizeOf = const $ natToNum @(SizeOf ControlSt) alignment = const $ natToNum @(Alignment ControlSt) @@ -177,11 +189,13 @@ instance (SizeOf ControlSt ~ 24, Alignment ControlSt ~ 4) newtype VecS (n :: Nat) a = VecS (Vec n a) -type instance SizeOf (VecS n a) = - SizeOf Int + n * SizeOf a +type instance + SizeOf (VecS n a) = + SizeOf Int + n * SizeOf a -type instance Alignment (VecS n a) = - Alignment a +type instance + Alignment (VecS n a) = + Alignment a instance ( Alignment a ~ Alignment Int @@ -190,8 +204,9 @@ instance , KnownNat (Alignment a) , KnownNat n , 1 <= n - ) - => Storable (VecS n a) where + ) => + Storable (VecS n a) + where sizeOf = const $ natToNum @(SizeOf (VecS n a)) alignment = const $ natToNum @(Alignment (VecS n a)) @@ -218,11 +233,13 @@ type Elems n = newtype RelDataCountS (n :: Nat) = RelDataCountS (Signed n) deriving newtype (Show, Eq, Ord, Bits, Num, Real, Integral, Enum) -type instance SizeOf (RelDataCountS n) = - SizeOf Int * Elems n +type instance + SizeOf (RelDataCountS n) = + SizeOf Int * Elems n -type instance Alignment (RelDataCountS n) = - SizeOf Int +type instance + Alignment (RelDataCountS n) = + SizeOf Int instance (KnownNat n, 1 <= n) => Storable (RelDataCountS n) where sizeOf = const $ natToNum @(SizeOf (RelDataCountS n)) @@ -238,9 +255,12 @@ instance (KnownNat n, 1 <= n) => Storable (RelDataCountS n) where toEnum' :: Int -> BitVector (BitsOf Int) toEnum' = toEnum - in - RelDataCountS . resize . unpack . pack - <$> (sequence $ map (fmap toEnum' . peekByteOff p . (* s) . fromEnum) v) + in + RelDataCountS + . resize + . unpack + . pack + <$> (sequence $ map (fmap toEnum' . peekByteOff p . (* s) . fromEnum) v) poke p (RelDataCountS c) = case oneMore @n @(BitsOf Int) of Dict -> @@ -257,5 +277,5 @@ instance (KnownNat n, 1 <= n) => Storable (RelDataCountS n) where BitVector (BitsOf (RelDataCountS n)) -> Vec (Elems n) (BitVector (BitsOf Int)) unpack' = unpack - in + in mapM_ (\(x, i) -> pokeByteOff p (s * fromEnum i) x) $ zip v indicesI diff --git a/bittide/src/Bittide/ClockControl/Callisto/Util.hs b/bittide/src/Bittide/ClockControl/Callisto/Util.hs index 14c351be1..5b269a04b 100644 --- a/bittide/src/Bittide/ClockControl/Callisto/Util.hs +++ b/bittide/src/Bittide/ClockControl/Callisto/Util.hs @@ -7,19 +7,21 @@ module Bittide.ClockControl.Callisto.Util where import Clash.Prelude -import Bittide.ClockControl (RelDataCount, SpeedChange(..)) +import Bittide.ClockControl (RelDataCount, SpeedChange (..)) --- | Safe 'RelDataCount' to 'Signed' conversion. --- (works for both: 'RelDataCount' being 'Signed' or 'Unsigned') +{- | Safe 'RelDataCount' to 'Signed' conversion. +(works for both: 'RelDataCount' being 'Signed' or 'Unsigned') +-} dataCountToSigned :: - forall n . - KnownNat n => + forall n. + (KnownNat n) => RelDataCount n -> Signed (n + 1) dataCountToSigned = bitCoerce . extend --- | A counter that starts at a given value, counts down, and if it reaches --- zero wraps around to the initial value. +{- | A counter that starts at a given value, counts down, and if it reaches +zero wraps around to the initial value. +-} wrappingCounter :: (HiddenClockResetEnable dom, KnownNat n) => Unsigned n -> @@ -31,8 +33,9 @@ wrappingCounter upper = counter go 0 = upper go n = pred n --- | A version of 'sum' that is guaranteed not to overflow. --- (works for both: 'RelDataCount' being 'Signed' or 'Unsigned') +{- | A version of 'sum' that is guaranteed not to overflow. +(works for both: 'RelDataCount' being 'Signed' or 'Unsigned') +-} safeSum :: ( KnownNat n , KnownNat m @@ -42,10 +45,11 @@ safeSum :: RelDataCount (m + n - 1) safeSum = sum . map extend --- | Sum a bunch of 'RelDataCount's to a @Signed 32@, without overflowing. --- (works for both: 'RelDataCount' being 'Signed' or 'Unsigned') +{- | Sum a bunch of 'RelDataCount's to a @Signed 32@, without overflowing. +(works for both: 'RelDataCount' being 'Signed' or 'Unsigned') +-} sumTo32 :: - forall n m . + forall n m. ( KnownNat m , KnownNat n , (m + n) <= 32 @@ -54,13 +58,13 @@ sumTo32 :: Vec n (RelDataCount m) -> Signed 32 sumTo32 = - extend @_ @_ @(32 - (m+n)) - . dataCountToSigned - . safeSum + extend @_ @_ @(32 - (m + n)) + . dataCountToSigned + . safeSum -- | Counts the number of 'high' bits in a bitvector. safePopCountTo32 :: - forall n . + forall n. ( KnownNat n , (1 + n) <= 32 , 1 <= n @@ -75,23 +79,25 @@ type FDEC = Bool speedChangeToPins :: SpeedChange -> (FINC, FDEC) speedChangeToPins = \case - SpeedUp -> (True, False) - SlowDown -> (False, True) - NoChange -> (False, False) + SpeedUp -> (True, False) + SlowDown -> (False, True) + NoChange -> (False, False) --- | Holds any @a@ which has any bits set for @stickyCycles@ clock cycles. --- On receiving a new @a@ with non-zero bits, it sets the new incoming value as it output --- and holds it for @stickyCycles@ clock cycles. +{- | Holds any @a@ which has any bits set for @stickyCycles@ clock cycles. +On receiving a new @a@ with non-zero bits, it sets the new incoming value as it output +and holds it for @stickyCycles@ clock cycles. +-} stickyBits :: - forall dom stickyCycles a . + forall dom stickyCycles a. ( HiddenClockResetEnable dom , NFDataX a , BitPack a - , 1 <= stickyCycles) => + , 1 <= stickyCycles + ) => SNat stickyCycles -> Signal dom a -> Signal dom a -stickyBits SNat = mealy go (0 , unpack 0) +stickyBits SNat = mealy go (0, unpack 0) where go :: (Index stickyCycles, a) -> a -> ((Index stickyCycles, a), a) go (count, storedBits) incomingBits = ((nextCount, nextStored), storedBits) @@ -102,4 +108,4 @@ stickyBits SNat = mealy go (0 , unpack 0) (nextStored, nextCount) | newIncoming = (incomingBits, maxBound) | holdingBits = (storedBits, predCount) - | otherwise = (unpack 0, predCount) + | otherwise = (unpack 0, predCount) diff --git a/bittide/src/Bittide/ClockControl/Foreign/Rust/Callisto.hs b/bittide/src/Bittide/ClockControl/Foreign/Rust/Callisto.hs index de12fae19..5c32dd614 100644 --- a/bittide/src/Bittide/ClockControl/Foreign/Rust/Callisto.hs +++ b/bittide/src/Bittide/ClockControl/Foreign/Rust/Callisto.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} @@ -9,9 +8,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} #endif -module Bittide.ClockControl.Foreign.Rust.Callisto - ( rustyCallisto - ) where +module Bittide.ClockControl.Foreign.Rust.Callisto ( + rustyCallisto, +) where import Clash.Prelude @@ -19,7 +18,7 @@ import Bittide.ClockControl (RelDataCount) import Bittide.ClockControl.Callisto.Types import Bittide.ClockControl.StabilityChecker -import Foreign.C.Types (CUInt(..)) +import Foreign.C.Types (CUInt (..)) #ifdef RUSTY_CALLISTO import Data.Word (Word32) diff --git a/bittide/src/Bittide/ClockControl/Foreign/Sizes.hs b/bittide/src/Bittide/ClockControl/Foreign/Sizes.hs index f23f217b3..f6e2b4bbb 100644 --- a/bittide/src/Bittide/ClockControl/Foreign/Sizes.hs +++ b/bittide/src/Bittide/ClockControl/Foreign/Sizes.hs @@ -1,8 +1,16 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 +-- DEVELOPER NOTE: This module currently encounters a lot of +-- redundancies regarding the utilized Template Haskell. They don't +-- have been simplified on purpose, because that would require some +-- multi-stage TH compilation, which triggers a bug in cabal, when +-- statically linking a foreign library. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -{-| +{- | 'Foreign.Storable.Storable' allows to define the size and alignment of raw memory storable types. However, those values currently are defined on the term level, although they can be statically determined at @@ -14,131 +22,286 @@ via type level 'GHC.TypeNats.Nat's. Template Haskell is used to determine the values of most of the common base types at compile time. -} - --- DEVELOPER NOTE: This module currently encounters a lot of --- redundancies regarding the utilized Template Haskell. They don't --- have been simplified on purpose, because that would require some --- multi-stage TH compilation, which triggers a bug in cabal, when --- statically linking a foreign library. -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} module Bittide.ClockControl.Foreign.Sizes where -import Prelude (Int, Word, Float, Double, ($), pure, undefined, toInteger) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (Nat) -import Language.Haskell.TH.Syntax (Type(..), TyLit(..)) +import Language.Haskell.TH.Syntax (TyLit (..), Type (..)) +import Prelude (Double, Float, Int, Word, pure, toInteger, undefined, ($)) import Foreign.C.Types -import Foreign.Ptr (Ptr, IntPtr, WordPtr) -import Foreign.Storable (sizeOf, alignment) +import Foreign.Ptr (IntPtr, Ptr, WordPtr) +import Foreign.Storable (alignment, sizeOf) -- | Type family for 'Foreign.Storable.Storable.sizeOf'. type family SizeOf a :: Nat -- Base Types -type instance SizeOf Int = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int)) -type instance SizeOf Word = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word)) -type instance SizeOf Float = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Float)) -type instance SizeOf Double = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Double)) +type instance + SizeOf Int = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int)) +type instance + SizeOf Word = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word)) +type instance + SizeOf Float = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Float)) +type instance + SizeOf Double = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Double)) -- Data.Int -type instance SizeOf Int8 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int8)) -type instance SizeOf Int16 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int16)) -type instance SizeOf Int32 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int32)) -type instance SizeOf Int64 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int64)) +type instance + SizeOf Int8 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int8)) +type instance + SizeOf Int16 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int16)) +type instance + SizeOf Int32 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int32)) +type instance + SizeOf Int64 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Int64)) -- Data.Word -type instance SizeOf Word8 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word8)) -type instance SizeOf Word16 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word16)) -type instance SizeOf Word32 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word32)) -type instance SizeOf Word64 = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word64)) +type instance + SizeOf Word8 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word8)) +type instance + SizeOf Word16 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word16)) +type instance + SizeOf Word32 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word32)) +type instance + SizeOf Word64 = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Word64)) -- Foreign.C.Types -type instance SizeOf CChar = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CChar)) -type instance SizeOf CSChar = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSChar)) -type instance SizeOf CUChar = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUChar)) -type instance SizeOf CShort = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CShort)) -type instance SizeOf CUShort = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUShort)) -type instance SizeOf CInt = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CInt)) -type instance SizeOf CUInt = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUInt)) -type instance SizeOf CLong = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CLong)) -type instance SizeOf CULong = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CULong)) -type instance SizeOf CPtrdiff = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CPtrdiff)) -type instance SizeOf CSize = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSize)) -type instance SizeOf CWchar = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CWchar)) -type instance SizeOf CSigAtomic = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSigAtomic)) -type instance SizeOf CLLong = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CLLong)) -type instance SizeOf CULLong = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CULLong)) -type instance SizeOf CBool = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CBool)) -type instance SizeOf CIntPtr = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CIntPtr)) -type instance SizeOf CUIntPtr = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUIntPtr)) -type instance SizeOf CIntMax = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CIntMax)) -type instance SizeOf CUIntMax = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUIntMax)) -type instance SizeOf CClock = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CClock)) -type instance SizeOf CTime = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CTime)) -type instance SizeOf CUSeconds = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUSeconds)) -type instance SizeOf CSUSeconds = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSUSeconds)) -type instance SizeOf CFloat = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CFloat)) -type instance SizeOf CDouble = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CDouble)) +type instance + SizeOf CChar = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CChar)) +type instance + SizeOf CSChar = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSChar)) +type instance + SizeOf CUChar = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUChar)) +type instance + SizeOf CShort = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CShort)) +type instance + SizeOf CUShort = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUShort)) +type instance + SizeOf CInt = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CInt)) +type instance + SizeOf CUInt = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUInt)) +type instance + SizeOf CLong = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CLong)) +type instance + SizeOf CULong = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CULong)) +type instance + SizeOf CPtrdiff = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CPtrdiff)) +type instance + SizeOf CSize = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSize)) +type instance + SizeOf CWchar = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CWchar)) +type instance + SizeOf CSigAtomic = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSigAtomic)) +type instance + SizeOf CLLong = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CLLong)) +type instance + SizeOf CULLong = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CULLong)) +type instance + SizeOf CBool = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CBool)) +type instance + SizeOf CIntPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CIntPtr)) +type instance + SizeOf CUIntPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUIntPtr)) +type instance + SizeOf CIntMax = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CIntMax)) +type instance + SizeOf CUIntMax = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUIntMax)) +type instance + SizeOf CClock = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CClock)) +type instance + SizeOf CTime = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CTime)) +type instance + SizeOf CUSeconds = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CUSeconds)) +type instance + SizeOf CSUSeconds = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CSUSeconds)) +type instance + SizeOf CFloat = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CFloat)) +type instance + SizeOf CDouble = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: CDouble)) -- Foreign.Ptr -type instance SizeOf (Ptr a) = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Ptr Int)) -type instance SizeOf IntPtr = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: IntPtr)) -type instance SizeOf WordPtr = $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: WordPtr)) +type instance + SizeOf (Ptr a) = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: Ptr Int)) +type instance + SizeOf IntPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: IntPtr)) +type instance + SizeOf WordPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ sizeOf (undefined :: WordPtr)) -- | Type family for 'Foreign.Storable.Storable.alignment'. type family Alignment a :: Nat -- Base Types -type instance Alignment Int = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int)) -type instance Alignment Word = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word)) -type instance Alignment Float = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Float)) -type instance Alignment Double = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Double)) +type instance + Alignment Int = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int)) +type instance + Alignment Word = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word)) +type instance + Alignment Float = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Float)) +type instance + Alignment Double = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Double)) -- Data.Int -type instance Alignment Int8 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int8)) -type instance Alignment Int16 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int16)) -type instance Alignment Int32 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int32)) -type instance Alignment Int64 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int64)) +type instance + Alignment Int8 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int8)) +type instance + Alignment Int16 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int16)) +type instance + Alignment Int32 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int32)) +type instance + Alignment Int64 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Int64)) -- Data.Word -type instance Alignment Word8 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word8)) -type instance Alignment Word16 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word16)) -type instance Alignment Word32 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word32)) -type instance Alignment Word64 = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word64)) +type instance + Alignment Word8 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word8)) +type instance + Alignment Word16 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word16)) +type instance + Alignment Word32 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word32)) +type instance + Alignment Word64 = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Word64)) -- Foreign.C.Types -type instance Alignment CChar = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CChar)) -type instance Alignment CSChar = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSChar)) -type instance Alignment CUChar = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUChar)) -type instance Alignment CShort = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CShort)) -type instance Alignment CUShort = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUShort)) -type instance Alignment CInt = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CInt)) -type instance Alignment CUInt = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUInt)) -type instance Alignment CLong = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CLong)) -type instance Alignment CULong = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CULong)) -type instance Alignment CPtrdiff = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CPtrdiff)) -type instance Alignment CSize = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSize)) -type instance Alignment CWchar = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CWchar)) -type instance Alignment CSigAtomic = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSigAtomic)) -type instance Alignment CLLong = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CLLong)) -type instance Alignment CULLong = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CULLong)) -type instance Alignment CBool = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CBool)) -type instance Alignment CIntPtr = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CIntPtr)) -type instance Alignment CUIntPtr = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUIntPtr)) -type instance Alignment CIntMax = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CIntMax)) -type instance Alignment CUIntMax = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUIntMax)) -type instance Alignment CClock = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CClock)) -type instance Alignment CTime = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CTime)) -type instance Alignment CUSeconds = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUSeconds)) -type instance Alignment CSUSeconds = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSUSeconds)) -type instance Alignment CFloat = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CFloat)) -type instance Alignment CDouble = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CDouble)) +type instance + Alignment CChar = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CChar)) +type instance + Alignment CSChar = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSChar)) +type instance + Alignment CUChar = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUChar)) +type instance + Alignment CShort = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CShort)) +type instance + Alignment CUShort = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUShort)) +type instance + Alignment CInt = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CInt)) +type instance + Alignment CUInt = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUInt)) +type instance + Alignment CLong = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CLong)) +type instance + Alignment CULong = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CULong)) +type instance + Alignment CPtrdiff = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CPtrdiff)) +type instance + Alignment CSize = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSize)) +type instance + Alignment CWchar = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CWchar)) +type instance + Alignment CSigAtomic = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSigAtomic)) +type instance + Alignment CLLong = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CLLong)) +type instance + Alignment CULLong = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CULLong)) +type instance + Alignment CBool = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CBool)) +type instance + Alignment CIntPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CIntPtr)) +type instance + Alignment CUIntPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUIntPtr)) +type instance + Alignment CIntMax = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CIntMax)) +type instance + Alignment CUIntMax = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUIntMax)) +type instance + Alignment CClock = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CClock)) +type instance + Alignment CTime = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CTime)) +type instance + Alignment CUSeconds = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CUSeconds)) +type instance + Alignment CSUSeconds = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CSUSeconds)) +type instance + Alignment CFloat = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CFloat)) +type instance + Alignment CDouble = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: CDouble)) -- Foreign.Ptr -type instance Alignment (Ptr a) = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Ptr Int)) -type instance Alignment IntPtr = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: IntPtr)) -type instance Alignment WordPtr = $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: WordPtr)) +type instance + Alignment (Ptr a) = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: Ptr Int)) +type instance + Alignment IntPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: IntPtr)) +type instance + Alignment WordPtr = + $(pure $ LitT $ NumTyLit $ toInteger $ alignment (undefined :: WordPtr)) diff --git a/bittide/src/Bittide/ClockControl/ParseRegisters.hs b/bittide/src/Bittide/ClockControl/ParseRegisters.hs index 61bbe6581..ac171b332 100644 --- a/bittide/src/Bittide/ClockControl/ParseRegisters.hs +++ b/bittide/src/Bittide/ClockControl/ParseRegisters.hs @@ -21,12 +21,13 @@ import Paths_bittide (getDataFileName) type Lines = [String] --- | Parse a triple of hex strings into a 'RegisterEntry'. --- --- >>> parseRegisterEntry "0x0850,0x00" --- Right (0b0000_1000,0b0101_0000,0b0000_0000) --- >>> parseRegisterEntry "0x0850,,," --- Left "Could not parse as triple: 0x0850,,," +{- | Parse a triple of hex strings into a 'RegisterEntry'. + +>>> parseRegisterEntry "0x0850,0x00" +Right (0b0000_1000,0b0101_0000,0b0000_0000) +>>> parseRegisterEntry "0x0850,,," +Left "Could not parse as triple: 0x0850,,," +-} parseRegisterEntry :: String -> Either String RegisterEntry parseRegisterEntry [_, _, h0, h1, h2, h3, _, _, _, h4, h5] = do n0 <- parseHex [h0, h1] @@ -38,30 +39,32 @@ parseRegisterEntry s = Left ("Could not parse as triple: " <> s) -- | Keep parsing register entries until a line starting with '#' is encountered. parseRegisterEntries :: Lines -> Either String ([RegisterEntry], Lines) parseRegisterEntries [] = Left "parseRegisterEntries: unexpected EOF" -parseRegisterEntries (l:ls0) +parseRegisterEntries (l : ls0) | "#" `isPrefixOf` l = pure ([], ls0) | otherwise = do - entry <- parseRegisterEntry l - (entries, ls1) <- parseRegisterEntries ls0 - pure (entry:entries, ls1) + entry <- parseRegisterEntry l + (entries, ls1) <- parseRegisterEntries ls0 + pure (entry : entries, ls1) --- | Consume lines until a line matching the given string is encountered, then --- parse register entries until a line starting with '#' is encountered. +{- | Consume lines until a line matching the given string is encountered, then +parse register entries until a line starting with '#' is encountered. +-} parseSection :: String -> Lines -> Either String ([RegisterEntry], Lines) parseSection s [] = Left ("parseSection: unexpected EOF for '" <> s <> "'") -parseSection s (l:ls) - | l == s = parseRegisterEntries ls +parseSection s (l : ls) + | l == s = parseRegisterEntries ls | otherwise = parseSection s ls --- | Parse a preamble, configuration, and postamble from a \"CSV\" file produced --- by ClockBuilder Pro. Note that this is not actually a CSV file, but multiple --- CSV files concatenated together, with comments (lines starting with @#@) in --- between. +{- | Parse a preamble, configuration, and postamble from a \"CSV\" file produced +by ClockBuilder Pro. Note that this is not actually a CSV file, but multiple +CSV files concatenated together, with comments (lines starting with @#@) in +between. +-} parse :: Lines -> Either String ([RegisterEntry], [RegisterEntry], [RegisterEntry]) parse ls0 = do (preamble, ls1) <- parseSection "# Start configuration preamble" ls0 - (config, ls2) <- parseSection "# Start configuration registers" ls1 - (postamble, _) <- parseSection "# Start configuration postamble" ls2 + (config, ls2) <- parseSection "# Start configuration registers" ls1 + (postamble, _) <- parseSection "# Start configuration postamble" ls2 pure (preamble, config, postamble) -- | Like 'parse', but reads from a file. @@ -70,8 +73,9 @@ parseFromFile :: IO (Either String ([RegisterEntry], [RegisterEntry], [RegisterEntry])) parseFromFile f = parse . map trim . lines <$> readFile f --- | Parse a CSV produced by ClockBuilder Pro into a 'Si539xRegisterMap' using --- Template Haskell. +{- | Parse a CSV produced by ClockBuilder Pro into a 'Si539xRegisterMap' using +Template Haskell. +-} parseFromFileToRegisterMap :: FilePath -> Q Exp parseFromFileToRegisterMap fileName = do path <- liftIO $ getDataFileName ("data" "clock_configs" fileName <> ".csv") @@ -79,7 +83,9 @@ parseFromFileToRegisterMap fileName = do case entries of Left err -> fail err Right (preamble, config, postamble) -> - [e| Si539xRegisterMap - $(listToVecTH preamble) - $(listToVecTH config) - $(listToVecTH postamble) |] + [e| + Si539xRegisterMap + $(listToVecTH preamble) + $(listToVecTH config) + $(listToVecTH postamble) + |] diff --git a/bittide/src/Bittide/ClockControl/Registers.hs b/bittide/src/Bittide/ClockControl/Registers.hs index e3b274378..66d64caba 100644 --- a/bittide/src/Bittide/ClockControl/Registers.hs +++ b/bittide/src/Bittide/ClockControl/Registers.hs @@ -1,11 +1,9 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-} - module Bittide.ClockControl.Registers where import Clash.Prelude @@ -14,8 +12,8 @@ import Protocols import Protocols.Wishbone import Bittide.ClockControl +import Bittide.ClockControl.Callisto.Util (speedChangeToPins, stickyBits) import Bittide.ClockControl.StabilityChecker -import Bittide.ClockControl.Callisto.Util (stickyBits, speedChangeToPins) import Bittide.Wishbone import Clash.Functor.Extra @@ -24,20 +22,21 @@ import Data.Maybe (fromMaybe) type StableBool = Bool type SettledBool = Bool --- | A wishbone accessible clock control interface. --- This interface receives the link mask and 'RelDataCount's from all links. --- Furthermore it produces FINC/FDEC pulses for the clock control boards. --- --- The word-aligned address layout of the Wishbone interface is as follows: --- --- - Address 0: Number of links --- - Address 1: Link mask --- - Address 2: FINC/FDEC --- - Address 3: Link stables --- - Address 4: Link settles --- - Addresses 5 to (5 + nLinks): Data counts +{- | A wishbone accessible clock control interface. +This interface receives the link mask and 'RelDataCount's from all links. +Furthermore it produces FINC/FDEC pulses for the clock control boards. + +The word-aligned address layout of the Wishbone interface is as follows: + +- Address 0: Number of links +- Address 1: Link mask +- Address 2: FINC/FDEC +- Address 3: Link stables +- Address 4: Link settles +- Addresses 5 to (5 + nLinks): Data counts +-} clockControlWb :: - forall dom addrW nLinks m margin framesize . + forall dom addrW nLinks m margin framesize. ( HiddenClockResetEnable dom , KnownNat addrW , 2 <= addrW @@ -65,20 +64,22 @@ clockControlWb :: (CSignal dom ("FINC" ::: Bool, "FDEC" ::: Bool), CSignal dom ("ALL_STABLE" ::: Bool)) clockControlWb margin framesize linkMask counters = Circuit go where - go (wbM2S, _) = (wbS2M, (fIncDec3, all (==True) <$> (fmap stable <$> stabilityIndications))) + go (wbM2S, _) = (wbS2M, (fIncDec3, all (== True) <$> (fmap stable <$> stabilityIndications))) where stabilityIndications = bundle $ stabilityChecker margin framesize <$> counters - readVec = dflipflop <$> ( - pure (natToNum @nLinks) - :> (zeroExtend @_ @_ @(32 - nLinks) <$> linkMask) - :> (resize . pack <$> fIncDec1) - :> (resize . pack . fmap stable <$> stabilityIndications) - :> (resize . pack . fmap settled <$> stabilityIndications) - :> (pack . (extend @_ @_ @(32 - m)) <<$>> counters)) + readVec = + dflipflop + <$> ( pure (natToNum @nLinks) + :> (zeroExtend @_ @_ @(32 - nLinks) <$> linkMask) + :> (resize . pack <$> fIncDec1) + :> (resize . pack . fmap stable <$> stabilityIndications) + :> (resize . pack . fmap settled <$> stabilityIndications) + :> (pack . (extend @_ @_ @(32 - m)) <<$>> counters) + ) fIncDec0 = (\v -> unpack . resize <$> v !! (2 :: Unsigned 2)) <$> writeVec fIncDec1 = register Nothing fIncDec0 fIncDec2 = fromMaybe NoChange <$> fIncDec1 fIncDec3 = - delay minBound {- glitch filter -} $ - stickyBits d20 (speedChangeToPins <$> fIncDec2) + delay minBound {- glitch filter -} + $ stickyBits d20 (speedChangeToPins <$> fIncDec2) (writeVec, wbS2M) = unbundle $ wbToVec <$> bundle readVec <*> wbM2S diff --git a/bittide/src/Bittide/ClockControl/Si5391A.hs b/bittide/src/Bittide/ClockControl/Si5391A.hs index 80bb24da6..aae1c4901 100644 --- a/bittide/src/Bittide/ClockControl/Si5391A.hs +++ b/bittide/src/Bittide/ClockControl/Si5391A.hs @@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE RecordWildCards #-} + module Bittide.ClockControl.Si5391A where import Clash.Prelude @@ -20,867 +21,869 @@ testConfigA = Si539xRegisterMap{..} configPreamble = (0x0B, 0x24, 0xC0) :> (0x0B, 0x25, 0x00) :> Nil configPostamble = (0x00, 0x1C, 0x01) :> (0x0B, 0x24, 0xC3) :> (0x0B, 0x25, 0x02) :> Nil config = - (0x00, 0x06, 0x00) :> - (0x00, 0x07, 0x00) :> - (0x00, 0x08, 0x00) :> - (0x00, 0x0B, 0x74) :> - (0x00, 0x17, 0xD0) :> - (0x00, 0x18, 0xFF) :> - (0x00, 0x21, 0x08) :> - (0x00, 0x22, 0x00) :> - (0x00, 0x2B, 0x02) :> - (0x00, 0x2C, 0x20) :> - (0x00, 0x2D, 0x00) :> - (0x00, 0x2E, 0x00) :> - (0x00, 0x2F, 0x00) :> - (0x00, 0x30, 0x00) :> - (0x00, 0x31, 0x00) :> - (0x00, 0x32, 0x00) :> - (0x00, 0x33, 0x00) :> - (0x00, 0x34, 0x00) :> - (0x00, 0x35, 0x00) :> - (0x00, 0x36, 0x00) :> - (0x00, 0x37, 0x00) :> - (0x00, 0x38, 0x00) :> - (0x00, 0x39, 0x00) :> - (0x00, 0x3A, 0x00) :> - (0x00, 0x3B, 0x00) :> - (0x00, 0x3C, 0x00) :> - (0x00, 0x3D, 0x00) :> - (0x00, 0x41, 0x00) :> - (0x00, 0x42, 0x00) :> - (0x00, 0x43, 0x00) :> - (0x00, 0x44, 0x00) :> - (0x00, 0x9E, 0x00) :> - (0x01, 0x02, 0x01) :> - (0x01, 0x03, 0x01) :> - (0x01, 0x04, 0x09) :> - (0x01, 0x05, 0x3E) :> - (0x01, 0x06, 0x18) :> - (0x01, 0x08, 0x01) :> - (0x01, 0x09, 0x09) :> - (0x01, 0x0A, 0x3B) :> - (0x01, 0x0B, 0x28) :> - (0x01, 0x0D, 0x01) :> - (0x01, 0x0E, 0xCC) :> - (0x01, 0x0F, 0x00) :> - (0x01, 0x10, 0x18) :> - (0x01, 0x12, 0x01) :> - (0x01, 0x13, 0x09) :> - (0x01, 0x14, 0x3B) :> - (0x01, 0x15, 0x28) :> - (0x01, 0x17, 0x01) :> - (0x01, 0x18, 0x09) :> - (0x01, 0x19, 0x3B) :> - (0x01, 0x1A, 0x28) :> - (0x01, 0x1C, 0x01) :> - (0x01, 0x1D, 0x09) :> - (0x01, 0x1E, 0x3B) :> - (0x01, 0x1F, 0x28) :> - (0x01, 0x21, 0x01) :> - (0x01, 0x22, 0x09) :> - (0x01, 0x23, 0x3B) :> - (0x01, 0x24, 0x28) :> - (0x01, 0x26, 0x01) :> - (0x01, 0x27, 0x09) :> - (0x01, 0x28, 0x3B) :> - (0x01, 0x29, 0x28) :> - (0x01, 0x2B, 0x01) :> - (0x01, 0x2C, 0x09) :> - (0x01, 0x2D, 0x3B) :> - (0x01, 0x2E, 0x28) :> - (0x01, 0x30, 0x01) :> - (0x01, 0x31, 0x09) :> - (0x01, 0x32, 0x3B) :> - (0x01, 0x33, 0x28) :> - (0x01, 0x35, 0x01) :> - (0x01, 0x36, 0x09) :> - (0x01, 0x37, 0x3B) :> - (0x01, 0x38, 0x28) :> - (0x01, 0x3A, 0x01) :> - (0x01, 0x3B, 0xCC) :> - (0x01, 0x3C, 0x00) :> - (0x01, 0x3D, 0x18) :> - (0x01, 0x3F, 0x00) :> - (0x01, 0x40, 0x00) :> - (0x01, 0x41, 0x40) :> - (0x02, 0x06, 0x00) :> - (0x02, 0x08, 0x00) :> - (0x02, 0x09, 0x00) :> - (0x02, 0x0A, 0x00) :> - (0x02, 0x0B, 0x00) :> - (0x02, 0x0C, 0x00) :> - (0x02, 0x0D, 0x00) :> - (0x02, 0x0E, 0x00) :> - (0x02, 0x0F, 0x00) :> - (0x02, 0x10, 0x00) :> - (0x02, 0x11, 0x00) :> - (0x02, 0x12, 0x00) :> - (0x02, 0x13, 0x00) :> - (0x02, 0x14, 0x00) :> - (0x02, 0x15, 0x00) :> - (0x02, 0x16, 0x00) :> - (0x02, 0x17, 0x00) :> - (0x02, 0x18, 0x00) :> - (0x02, 0x19, 0x00) :> - (0x02, 0x1A, 0x00) :> - (0x02, 0x1B, 0x00) :> - (0x02, 0x1C, 0x00) :> - (0x02, 0x1D, 0x00) :> - (0x02, 0x1E, 0x00) :> - (0x02, 0x1F, 0x00) :> - (0x02, 0x20, 0x00) :> - (0x02, 0x21, 0x00) :> - (0x02, 0x22, 0x00) :> - (0x02, 0x23, 0x00) :> - (0x02, 0x24, 0x00) :> - (0x02, 0x25, 0x00) :> - (0x02, 0x26, 0x00) :> - (0x02, 0x27, 0x00) :> - (0x02, 0x28, 0x00) :> - (0x02, 0x29, 0x00) :> - (0x02, 0x2A, 0x00) :> - (0x02, 0x2B, 0x00) :> - (0x02, 0x2C, 0x00) :> - (0x02, 0x2D, 0x00) :> - (0x02, 0x2E, 0x00) :> - (0x02, 0x2F, 0x00) :> - (0x02, 0x35, 0x00) :> - (0x02, 0x36, 0x00) :> - (0x02, 0x37, 0x00) :> - (0x02, 0x38, 0x00) :> - (0x02, 0x39, 0x00) :> - (0x02, 0x3A, 0x00) :> - (0x02, 0x3B, 0x00) :> - (0x02, 0x3C, 0x00) :> - (0x02, 0x3D, 0x00) :> - (0x02, 0x3E, 0x00) :> - (0x02, 0x47, 0x00) :> - (0x02, 0x48, 0x00) :> - (0x02, 0x49, 0x00) :> - (0x02, 0x4A, 0x00) :> - (0x02, 0x4B, 0x00) :> - (0x02, 0x4C, 0x00) :> - (0x02, 0x4D, 0x00) :> - (0x02, 0x4E, 0x00) :> - (0x02, 0x4F, 0x00) :> - (0x02, 0x50, 0x00) :> - (0x02, 0x51, 0x00) :> - (0x02, 0x52, 0x00) :> - (0x02, 0x53, 0x00) :> - (0x02, 0x54, 0x00) :> - (0x02, 0x55, 0x00) :> - (0x02, 0x56, 0x00) :> - (0x02, 0x57, 0x00) :> - (0x02, 0x58, 0x00) :> - (0x02, 0x59, 0x00) :> - (0x02, 0x5A, 0x00) :> - (0x02, 0x5B, 0x00) :> - (0x02, 0x5C, 0x00) :> - (0x02, 0x5D, 0x00) :> - (0x02, 0x5E, 0x00) :> - (0x02, 0x5F, 0x00) :> - (0x02, 0x60, 0x00) :> - (0x02, 0x61, 0x00) :> - (0x02, 0x62, 0x00) :> - (0x02, 0x63, 0x00) :> - (0x02, 0x64, 0x00) :> - (0x02, 0x65, 0x00) :> - (0x02, 0x66, 0x00) :> - (0x02, 0x67, 0x00) :> - (0x02, 0x68, 0x00) :> - (0x02, 0x69, 0x00) :> - (0x02, 0x6A, 0x00) :> - (0x02, 0x6B, 0x35) :> - (0x02, 0x6C, 0x33) :> - (0x02, 0x6D, 0x39) :> - (0x02, 0x6E, 0x31) :> - (0x02, 0x6F, 0x41) :> - (0x02, 0x70, 0x45) :> - (0x02, 0x71, 0x56) :> - (0x02, 0x72, 0x42) :> - (0x03, 0x02, 0x00) :> - (0x03, 0x03, 0x00) :> - (0x03, 0x04, 0x00) :> - (0x03, 0x05, 0x00) :> - (0x03, 0x06, 0x00) :> - (0x03, 0x07, 0x00) :> - (0x03, 0x08, 0x00) :> - (0x03, 0x09, 0x00) :> - (0x03, 0x0A, 0x00) :> - (0x03, 0x0B, 0x00) :> - (0x03, 0x0C, 0x00) :> - (0x03, 0x0D, 0x00) :> - (0x03, 0x0E, 0x00) :> - (0x03, 0x0F, 0x00) :> - (0x03, 0x10, 0x00) :> - (0x03, 0x11, 0x00) :> - (0x03, 0x12, 0x00) :> - (0x03, 0x13, 0x00) :> - (0x03, 0x14, 0x00) :> - (0x03, 0x15, 0x00) :> - (0x03, 0x16, 0x00) :> - (0x03, 0x17, 0x00) :> - (0x03, 0x18, 0x00) :> - (0x03, 0x19, 0x00) :> - (0x03, 0x1A, 0x00) :> - (0x03, 0x1B, 0x00) :> - (0x03, 0x1C, 0x00) :> - (0x03, 0x1D, 0x00) :> - (0x03, 0x1E, 0x00) :> - (0x03, 0x1F, 0x00) :> - (0x03, 0x20, 0x00) :> - (0x03, 0x21, 0x00) :> - (0x03, 0x22, 0x00) :> - (0x03, 0x23, 0x00) :> - (0x03, 0x24, 0x00) :> - (0x03, 0x25, 0x00) :> - (0x03, 0x26, 0x00) :> - (0x03, 0x27, 0x00) :> - (0x03, 0x28, 0x00) :> - (0x03, 0x29, 0x00) :> - (0x03, 0x2A, 0x00) :> - (0x03, 0x2B, 0x00) :> - (0x03, 0x2C, 0x00) :> - (0x03, 0x2D, 0x00) :> - (0x03, 0x2E, 0x00) :> - (0x03, 0x2F, 0x00) :> - (0x03, 0x30, 0x00) :> - (0x03, 0x31, 0x00) :> - (0x03, 0x32, 0x00) :> - (0x03, 0x33, 0x00) :> - (0x03, 0x34, 0x00) :> - (0x03, 0x35, 0x00) :> - (0x03, 0x36, 0x00) :> - (0x03, 0x37, 0x00) :> - (0x03, 0x38, 0x00) :> - (0x03, 0x39, 0x1F) :> - (0x03, 0x3B, 0x00) :> - (0x03, 0x3C, 0x00) :> - (0x03, 0x3D, 0x00) :> - (0x03, 0x3E, 0x00) :> - (0x03, 0x3F, 0x00) :> - (0x03, 0x40, 0x00) :> - (0x03, 0x41, 0x00) :> - (0x03, 0x42, 0x00) :> - (0x03, 0x43, 0x00) :> - (0x03, 0x44, 0x00) :> - (0x03, 0x45, 0x00) :> - (0x03, 0x46, 0x00) :> - (0x03, 0x47, 0x00) :> - (0x03, 0x48, 0x00) :> - (0x03, 0x49, 0x00) :> - (0x03, 0x4A, 0x00) :> - (0x03, 0x4B, 0x00) :> - (0x03, 0x4C, 0x00) :> - (0x03, 0x4D, 0x00) :> - (0x03, 0x4E, 0x00) :> - (0x03, 0x4F, 0x00) :> - (0x03, 0x50, 0x00) :> - (0x03, 0x51, 0x00) :> - (0x03, 0x52, 0x00) :> - (0x03, 0x53, 0x00) :> - (0x03, 0x54, 0x00) :> - (0x03, 0x55, 0x00) :> - (0x03, 0x56, 0x00) :> - (0x03, 0x57, 0x00) :> - (0x03, 0x58, 0x00) :> - (0x03, 0x59, 0x00) :> - (0x03, 0x5A, 0x00) :> - (0x03, 0x5B, 0x00) :> - (0x03, 0x5C, 0x00) :> - (0x03, 0x5D, 0x00) :> - (0x03, 0x5E, 0x00) :> - (0x03, 0x5F, 0x00) :> - (0x03, 0x60, 0x00) :> - (0x03, 0x61, 0x00) :> - (0x03, 0x62, 0x00) :> - (0x08, 0x02, 0x00) :> - (0x08, 0x03, 0x00) :> - (0x08, 0x04, 0x00) :> - (0x08, 0x05, 0x00) :> - (0x08, 0x06, 0x00) :> - (0x08, 0x07, 0x00) :> - (0x08, 0x08, 0x00) :> - (0x08, 0x09, 0x00) :> - (0x08, 0x0A, 0x00) :> - (0x08, 0x0B, 0x00) :> - (0x08, 0x0C, 0x00) :> - (0x08, 0x0D, 0x00) :> - (0x08, 0x0E, 0x00) :> - (0x08, 0x0F, 0x00) :> - (0x08, 0x10, 0x00) :> - (0x08, 0x11, 0x00) :> - (0x08, 0x12, 0x00) :> - (0x08, 0x13, 0x00) :> - (0x08, 0x14, 0x00) :> - (0x08, 0x15, 0x00) :> - (0x08, 0x16, 0x00) :> - (0x08, 0x17, 0x00) :> - (0x08, 0x18, 0x00) :> - (0x08, 0x19, 0x00) :> - (0x08, 0x1A, 0x00) :> - (0x08, 0x1B, 0x00) :> - (0x08, 0x1C, 0x00) :> - (0x08, 0x1D, 0x00) :> - (0x08, 0x1E, 0x00) :> - (0x08, 0x1F, 0x00) :> - (0x08, 0x20, 0x00) :> - (0x08, 0x21, 0x00) :> - (0x08, 0x22, 0x00) :> - (0x08, 0x23, 0x00) :> - (0x08, 0x24, 0x00) :> - (0x08, 0x25, 0x00) :> - (0x08, 0x26, 0x00) :> - (0x08, 0x27, 0x00) :> - (0x08, 0x28, 0x00) :> - (0x08, 0x29, 0x00) :> - (0x08, 0x2A, 0x00) :> - (0x08, 0x2B, 0x00) :> - (0x08, 0x2C, 0x00) :> - (0x08, 0x2D, 0x00) :> - (0x08, 0x2E, 0x00) :> - (0x08, 0x2F, 0x00) :> - (0x08, 0x30, 0x00) :> - (0x08, 0x31, 0x00) :> - (0x08, 0x32, 0x00) :> - (0x08, 0x33, 0x00) :> - (0x08, 0x34, 0x00) :> - (0x08, 0x35, 0x00) :> - (0x08, 0x36, 0x00) :> - (0x08, 0x37, 0x00) :> - (0x08, 0x38, 0x00) :> - (0x08, 0x39, 0x00) :> - (0x08, 0x3A, 0x00) :> - (0x08, 0x3B, 0x00) :> - (0x08, 0x3C, 0x00) :> - (0x08, 0x3D, 0x00) :> - (0x08, 0x3E, 0x00) :> - (0x08, 0x3F, 0x00) :> - (0x08, 0x40, 0x00) :> - (0x08, 0x41, 0x00) :> - (0x08, 0x42, 0x00) :> - (0x08, 0x43, 0x00) :> - (0x08, 0x44, 0x00) :> - (0x08, 0x45, 0x00) :> - (0x08, 0x46, 0x00) :> - (0x08, 0x47, 0x00) :> - (0x08, 0x48, 0x00) :> - (0x08, 0x49, 0x00) :> - (0x08, 0x4A, 0x00) :> - (0x08, 0x4B, 0x00) :> - (0x08, 0x4C, 0x00) :> - (0x08, 0x4D, 0x00) :> - (0x08, 0x4E, 0x00) :> - (0x08, 0x4F, 0x00) :> - (0x08, 0x50, 0x00) :> - (0x08, 0x51, 0x00) :> - (0x08, 0x52, 0x00) :> - (0x08, 0x53, 0x00) :> - (0x08, 0x54, 0x00) :> - (0x08, 0x55, 0x00) :> - (0x08, 0x56, 0x00) :> - (0x08, 0x57, 0x00) :> - (0x08, 0x58, 0x00) :> - (0x08, 0x59, 0x00) :> - (0x08, 0x5A, 0x00) :> - (0x08, 0x5B, 0x00) :> - (0x08, 0x5C, 0x00) :> - (0x08, 0x5D, 0x00) :> - (0x08, 0x5E, 0x00) :> - (0x08, 0x5F, 0x00) :> - (0x08, 0x60, 0x00) :> - (0x08, 0x61, 0x00) :> - (0x09, 0x0E, 0x02) :> - (0x09, 0x1C, 0x04) :> - (0x09, 0x43, 0x01) :> - (0x09, 0x49, 0x00) :> - (0x09, 0x4A, 0xF0) :> - (0x09, 0x4E, 0x49) :> - (0x09, 0x4F, 0xF2) :> - (0x09, 0x5E, 0x00) :> - (0x0A, 0x02, 0x00) :> - (0x0A, 0x03, 0x1F) :> - (0x0A, 0x04, 0x00) :> - (0x0A, 0x05, 0x1F) :> - (0x0A, 0x14, 0x00) :> - (0x0A, 0x1A, 0x00) :> - (0x0A, 0x20, 0x00) :> - (0x0A, 0x26, 0x00) :> - (0x0A, 0x2C, 0x00) :> - (0x0A, 0x38, 0x00) :> - (0x0A, 0x39, 0x00) :> - (0x0A, 0x3A, 0x00) :> - (0x0A, 0x3C, 0x00) :> - (0x0A, 0x3D, 0x00) :> - (0x0A, 0x3E, 0x00) :> - (0x0A, 0x40, 0x00) :> - (0x0A, 0x41, 0x00) :> - (0x0A, 0x42, 0x00) :> - (0x0A, 0x44, 0x00) :> - (0x0A, 0x45, 0x00) :> - (0x0A, 0x46, 0x00) :> - (0x0A, 0x48, 0x00) :> - (0x0A, 0x49, 0x00) :> - (0x0A, 0x4A, 0x00) :> - (0x0A, 0x4C, 0x00) :> - (0x0A, 0x4D, 0x00) :> - (0x0A, 0x4E, 0x00) :> - (0x0A, 0x4F, 0x00) :> - (0x0A, 0x50, 0x00) :> - (0x0A, 0x51, 0x00) :> - (0x0A, 0x52, 0x00) :> - (0x0A, 0x53, 0x00) :> - (0x0A, 0x54, 0x00) :> - (0x0A, 0x55, 0x00) :> - (0x0A, 0x56, 0x00) :> - (0x0A, 0x57, 0x00) :> - (0x0A, 0x58, 0x00) :> - (0x0A, 0x59, 0x00) :> - (0x0A, 0x5A, 0x00) :> - (0x0A, 0x5B, 0x00) :> - (0x0A, 0x5C, 0x00) :> - (0x0A, 0x5D, 0x00) :> - (0x0A, 0x5E, 0x00) :> - (0x0A, 0x5F, 0x00) :> - (0x0B, 0x44, 0x00) :> - (0x0B, 0x4A, 0x00) :> - (0x0B, 0x57, 0x0E) :> - (0x0B, 0x58, 0x01) :> Nil - + (0x00, 0x06, 0x00) + :> (0x00, 0x07, 0x00) + :> (0x00, 0x08, 0x00) + :> (0x00, 0x0B, 0x74) + :> (0x00, 0x17, 0xD0) + :> (0x00, 0x18, 0xFF) + :> (0x00, 0x21, 0x08) + :> (0x00, 0x22, 0x00) + :> (0x00, 0x2B, 0x02) + :> (0x00, 0x2C, 0x20) + :> (0x00, 0x2D, 0x00) + :> (0x00, 0x2E, 0x00) + :> (0x00, 0x2F, 0x00) + :> (0x00, 0x30, 0x00) + :> (0x00, 0x31, 0x00) + :> (0x00, 0x32, 0x00) + :> (0x00, 0x33, 0x00) + :> (0x00, 0x34, 0x00) + :> (0x00, 0x35, 0x00) + :> (0x00, 0x36, 0x00) + :> (0x00, 0x37, 0x00) + :> (0x00, 0x38, 0x00) + :> (0x00, 0x39, 0x00) + :> (0x00, 0x3A, 0x00) + :> (0x00, 0x3B, 0x00) + :> (0x00, 0x3C, 0x00) + :> (0x00, 0x3D, 0x00) + :> (0x00, 0x41, 0x00) + :> (0x00, 0x42, 0x00) + :> (0x00, 0x43, 0x00) + :> (0x00, 0x44, 0x00) + :> (0x00, 0x9E, 0x00) + :> (0x01, 0x02, 0x01) + :> (0x01, 0x03, 0x01) + :> (0x01, 0x04, 0x09) + :> (0x01, 0x05, 0x3E) + :> (0x01, 0x06, 0x18) + :> (0x01, 0x08, 0x01) + :> (0x01, 0x09, 0x09) + :> (0x01, 0x0A, 0x3B) + :> (0x01, 0x0B, 0x28) + :> (0x01, 0x0D, 0x01) + :> (0x01, 0x0E, 0xCC) + :> (0x01, 0x0F, 0x00) + :> (0x01, 0x10, 0x18) + :> (0x01, 0x12, 0x01) + :> (0x01, 0x13, 0x09) + :> (0x01, 0x14, 0x3B) + :> (0x01, 0x15, 0x28) + :> (0x01, 0x17, 0x01) + :> (0x01, 0x18, 0x09) + :> (0x01, 0x19, 0x3B) + :> (0x01, 0x1A, 0x28) + :> (0x01, 0x1C, 0x01) + :> (0x01, 0x1D, 0x09) + :> (0x01, 0x1E, 0x3B) + :> (0x01, 0x1F, 0x28) + :> (0x01, 0x21, 0x01) + :> (0x01, 0x22, 0x09) + :> (0x01, 0x23, 0x3B) + :> (0x01, 0x24, 0x28) + :> (0x01, 0x26, 0x01) + :> (0x01, 0x27, 0x09) + :> (0x01, 0x28, 0x3B) + :> (0x01, 0x29, 0x28) + :> (0x01, 0x2B, 0x01) + :> (0x01, 0x2C, 0x09) + :> (0x01, 0x2D, 0x3B) + :> (0x01, 0x2E, 0x28) + :> (0x01, 0x30, 0x01) + :> (0x01, 0x31, 0x09) + :> (0x01, 0x32, 0x3B) + :> (0x01, 0x33, 0x28) + :> (0x01, 0x35, 0x01) + :> (0x01, 0x36, 0x09) + :> (0x01, 0x37, 0x3B) + :> (0x01, 0x38, 0x28) + :> (0x01, 0x3A, 0x01) + :> (0x01, 0x3B, 0xCC) + :> (0x01, 0x3C, 0x00) + :> (0x01, 0x3D, 0x18) + :> (0x01, 0x3F, 0x00) + :> (0x01, 0x40, 0x00) + :> (0x01, 0x41, 0x40) + :> (0x02, 0x06, 0x00) + :> (0x02, 0x08, 0x00) + :> (0x02, 0x09, 0x00) + :> (0x02, 0x0A, 0x00) + :> (0x02, 0x0B, 0x00) + :> (0x02, 0x0C, 0x00) + :> (0x02, 0x0D, 0x00) + :> (0x02, 0x0E, 0x00) + :> (0x02, 0x0F, 0x00) + :> (0x02, 0x10, 0x00) + :> (0x02, 0x11, 0x00) + :> (0x02, 0x12, 0x00) + :> (0x02, 0x13, 0x00) + :> (0x02, 0x14, 0x00) + :> (0x02, 0x15, 0x00) + :> (0x02, 0x16, 0x00) + :> (0x02, 0x17, 0x00) + :> (0x02, 0x18, 0x00) + :> (0x02, 0x19, 0x00) + :> (0x02, 0x1A, 0x00) + :> (0x02, 0x1B, 0x00) + :> (0x02, 0x1C, 0x00) + :> (0x02, 0x1D, 0x00) + :> (0x02, 0x1E, 0x00) + :> (0x02, 0x1F, 0x00) + :> (0x02, 0x20, 0x00) + :> (0x02, 0x21, 0x00) + :> (0x02, 0x22, 0x00) + :> (0x02, 0x23, 0x00) + :> (0x02, 0x24, 0x00) + :> (0x02, 0x25, 0x00) + :> (0x02, 0x26, 0x00) + :> (0x02, 0x27, 0x00) + :> (0x02, 0x28, 0x00) + :> (0x02, 0x29, 0x00) + :> (0x02, 0x2A, 0x00) + :> (0x02, 0x2B, 0x00) + :> (0x02, 0x2C, 0x00) + :> (0x02, 0x2D, 0x00) + :> (0x02, 0x2E, 0x00) + :> (0x02, 0x2F, 0x00) + :> (0x02, 0x35, 0x00) + :> (0x02, 0x36, 0x00) + :> (0x02, 0x37, 0x00) + :> (0x02, 0x38, 0x00) + :> (0x02, 0x39, 0x00) + :> (0x02, 0x3A, 0x00) + :> (0x02, 0x3B, 0x00) + :> (0x02, 0x3C, 0x00) + :> (0x02, 0x3D, 0x00) + :> (0x02, 0x3E, 0x00) + :> (0x02, 0x47, 0x00) + :> (0x02, 0x48, 0x00) + :> (0x02, 0x49, 0x00) + :> (0x02, 0x4A, 0x00) + :> (0x02, 0x4B, 0x00) + :> (0x02, 0x4C, 0x00) + :> (0x02, 0x4D, 0x00) + :> (0x02, 0x4E, 0x00) + :> (0x02, 0x4F, 0x00) + :> (0x02, 0x50, 0x00) + :> (0x02, 0x51, 0x00) + :> (0x02, 0x52, 0x00) + :> (0x02, 0x53, 0x00) + :> (0x02, 0x54, 0x00) + :> (0x02, 0x55, 0x00) + :> (0x02, 0x56, 0x00) + :> (0x02, 0x57, 0x00) + :> (0x02, 0x58, 0x00) + :> (0x02, 0x59, 0x00) + :> (0x02, 0x5A, 0x00) + :> (0x02, 0x5B, 0x00) + :> (0x02, 0x5C, 0x00) + :> (0x02, 0x5D, 0x00) + :> (0x02, 0x5E, 0x00) + :> (0x02, 0x5F, 0x00) + :> (0x02, 0x60, 0x00) + :> (0x02, 0x61, 0x00) + :> (0x02, 0x62, 0x00) + :> (0x02, 0x63, 0x00) + :> (0x02, 0x64, 0x00) + :> (0x02, 0x65, 0x00) + :> (0x02, 0x66, 0x00) + :> (0x02, 0x67, 0x00) + :> (0x02, 0x68, 0x00) + :> (0x02, 0x69, 0x00) + :> (0x02, 0x6A, 0x00) + :> (0x02, 0x6B, 0x35) + :> (0x02, 0x6C, 0x33) + :> (0x02, 0x6D, 0x39) + :> (0x02, 0x6E, 0x31) + :> (0x02, 0x6F, 0x41) + :> (0x02, 0x70, 0x45) + :> (0x02, 0x71, 0x56) + :> (0x02, 0x72, 0x42) + :> (0x03, 0x02, 0x00) + :> (0x03, 0x03, 0x00) + :> (0x03, 0x04, 0x00) + :> (0x03, 0x05, 0x00) + :> (0x03, 0x06, 0x00) + :> (0x03, 0x07, 0x00) + :> (0x03, 0x08, 0x00) + :> (0x03, 0x09, 0x00) + :> (0x03, 0x0A, 0x00) + :> (0x03, 0x0B, 0x00) + :> (0x03, 0x0C, 0x00) + :> (0x03, 0x0D, 0x00) + :> (0x03, 0x0E, 0x00) + :> (0x03, 0x0F, 0x00) + :> (0x03, 0x10, 0x00) + :> (0x03, 0x11, 0x00) + :> (0x03, 0x12, 0x00) + :> (0x03, 0x13, 0x00) + :> (0x03, 0x14, 0x00) + :> (0x03, 0x15, 0x00) + :> (0x03, 0x16, 0x00) + :> (0x03, 0x17, 0x00) + :> (0x03, 0x18, 0x00) + :> (0x03, 0x19, 0x00) + :> (0x03, 0x1A, 0x00) + :> (0x03, 0x1B, 0x00) + :> (0x03, 0x1C, 0x00) + :> (0x03, 0x1D, 0x00) + :> (0x03, 0x1E, 0x00) + :> (0x03, 0x1F, 0x00) + :> (0x03, 0x20, 0x00) + :> (0x03, 0x21, 0x00) + :> (0x03, 0x22, 0x00) + :> (0x03, 0x23, 0x00) + :> (0x03, 0x24, 0x00) + :> (0x03, 0x25, 0x00) + :> (0x03, 0x26, 0x00) + :> (0x03, 0x27, 0x00) + :> (0x03, 0x28, 0x00) + :> (0x03, 0x29, 0x00) + :> (0x03, 0x2A, 0x00) + :> (0x03, 0x2B, 0x00) + :> (0x03, 0x2C, 0x00) + :> (0x03, 0x2D, 0x00) + :> (0x03, 0x2E, 0x00) + :> (0x03, 0x2F, 0x00) + :> (0x03, 0x30, 0x00) + :> (0x03, 0x31, 0x00) + :> (0x03, 0x32, 0x00) + :> (0x03, 0x33, 0x00) + :> (0x03, 0x34, 0x00) + :> (0x03, 0x35, 0x00) + :> (0x03, 0x36, 0x00) + :> (0x03, 0x37, 0x00) + :> (0x03, 0x38, 0x00) + :> (0x03, 0x39, 0x1F) + :> (0x03, 0x3B, 0x00) + :> (0x03, 0x3C, 0x00) + :> (0x03, 0x3D, 0x00) + :> (0x03, 0x3E, 0x00) + :> (0x03, 0x3F, 0x00) + :> (0x03, 0x40, 0x00) + :> (0x03, 0x41, 0x00) + :> (0x03, 0x42, 0x00) + :> (0x03, 0x43, 0x00) + :> (0x03, 0x44, 0x00) + :> (0x03, 0x45, 0x00) + :> (0x03, 0x46, 0x00) + :> (0x03, 0x47, 0x00) + :> (0x03, 0x48, 0x00) + :> (0x03, 0x49, 0x00) + :> (0x03, 0x4A, 0x00) + :> (0x03, 0x4B, 0x00) + :> (0x03, 0x4C, 0x00) + :> (0x03, 0x4D, 0x00) + :> (0x03, 0x4E, 0x00) + :> (0x03, 0x4F, 0x00) + :> (0x03, 0x50, 0x00) + :> (0x03, 0x51, 0x00) + :> (0x03, 0x52, 0x00) + :> (0x03, 0x53, 0x00) + :> (0x03, 0x54, 0x00) + :> (0x03, 0x55, 0x00) + :> (0x03, 0x56, 0x00) + :> (0x03, 0x57, 0x00) + :> (0x03, 0x58, 0x00) + :> (0x03, 0x59, 0x00) + :> (0x03, 0x5A, 0x00) + :> (0x03, 0x5B, 0x00) + :> (0x03, 0x5C, 0x00) + :> (0x03, 0x5D, 0x00) + :> (0x03, 0x5E, 0x00) + :> (0x03, 0x5F, 0x00) + :> (0x03, 0x60, 0x00) + :> (0x03, 0x61, 0x00) + :> (0x03, 0x62, 0x00) + :> (0x08, 0x02, 0x00) + :> (0x08, 0x03, 0x00) + :> (0x08, 0x04, 0x00) + :> (0x08, 0x05, 0x00) + :> (0x08, 0x06, 0x00) + :> (0x08, 0x07, 0x00) + :> (0x08, 0x08, 0x00) + :> (0x08, 0x09, 0x00) + :> (0x08, 0x0A, 0x00) + :> (0x08, 0x0B, 0x00) + :> (0x08, 0x0C, 0x00) + :> (0x08, 0x0D, 0x00) + :> (0x08, 0x0E, 0x00) + :> (0x08, 0x0F, 0x00) + :> (0x08, 0x10, 0x00) + :> (0x08, 0x11, 0x00) + :> (0x08, 0x12, 0x00) + :> (0x08, 0x13, 0x00) + :> (0x08, 0x14, 0x00) + :> (0x08, 0x15, 0x00) + :> (0x08, 0x16, 0x00) + :> (0x08, 0x17, 0x00) + :> (0x08, 0x18, 0x00) + :> (0x08, 0x19, 0x00) + :> (0x08, 0x1A, 0x00) + :> (0x08, 0x1B, 0x00) + :> (0x08, 0x1C, 0x00) + :> (0x08, 0x1D, 0x00) + :> (0x08, 0x1E, 0x00) + :> (0x08, 0x1F, 0x00) + :> (0x08, 0x20, 0x00) + :> (0x08, 0x21, 0x00) + :> (0x08, 0x22, 0x00) + :> (0x08, 0x23, 0x00) + :> (0x08, 0x24, 0x00) + :> (0x08, 0x25, 0x00) + :> (0x08, 0x26, 0x00) + :> (0x08, 0x27, 0x00) + :> (0x08, 0x28, 0x00) + :> (0x08, 0x29, 0x00) + :> (0x08, 0x2A, 0x00) + :> (0x08, 0x2B, 0x00) + :> (0x08, 0x2C, 0x00) + :> (0x08, 0x2D, 0x00) + :> (0x08, 0x2E, 0x00) + :> (0x08, 0x2F, 0x00) + :> (0x08, 0x30, 0x00) + :> (0x08, 0x31, 0x00) + :> (0x08, 0x32, 0x00) + :> (0x08, 0x33, 0x00) + :> (0x08, 0x34, 0x00) + :> (0x08, 0x35, 0x00) + :> (0x08, 0x36, 0x00) + :> (0x08, 0x37, 0x00) + :> (0x08, 0x38, 0x00) + :> (0x08, 0x39, 0x00) + :> (0x08, 0x3A, 0x00) + :> (0x08, 0x3B, 0x00) + :> (0x08, 0x3C, 0x00) + :> (0x08, 0x3D, 0x00) + :> (0x08, 0x3E, 0x00) + :> (0x08, 0x3F, 0x00) + :> (0x08, 0x40, 0x00) + :> (0x08, 0x41, 0x00) + :> (0x08, 0x42, 0x00) + :> (0x08, 0x43, 0x00) + :> (0x08, 0x44, 0x00) + :> (0x08, 0x45, 0x00) + :> (0x08, 0x46, 0x00) + :> (0x08, 0x47, 0x00) + :> (0x08, 0x48, 0x00) + :> (0x08, 0x49, 0x00) + :> (0x08, 0x4A, 0x00) + :> (0x08, 0x4B, 0x00) + :> (0x08, 0x4C, 0x00) + :> (0x08, 0x4D, 0x00) + :> (0x08, 0x4E, 0x00) + :> (0x08, 0x4F, 0x00) + :> (0x08, 0x50, 0x00) + :> (0x08, 0x51, 0x00) + :> (0x08, 0x52, 0x00) + :> (0x08, 0x53, 0x00) + :> (0x08, 0x54, 0x00) + :> (0x08, 0x55, 0x00) + :> (0x08, 0x56, 0x00) + :> (0x08, 0x57, 0x00) + :> (0x08, 0x58, 0x00) + :> (0x08, 0x59, 0x00) + :> (0x08, 0x5A, 0x00) + :> (0x08, 0x5B, 0x00) + :> (0x08, 0x5C, 0x00) + :> (0x08, 0x5D, 0x00) + :> (0x08, 0x5E, 0x00) + :> (0x08, 0x5F, 0x00) + :> (0x08, 0x60, 0x00) + :> (0x08, 0x61, 0x00) + :> (0x09, 0x0E, 0x02) + :> (0x09, 0x1C, 0x04) + :> (0x09, 0x43, 0x01) + :> (0x09, 0x49, 0x00) + :> (0x09, 0x4A, 0xF0) + :> (0x09, 0x4E, 0x49) + :> (0x09, 0x4F, 0xF2) + :> (0x09, 0x5E, 0x00) + :> (0x0A, 0x02, 0x00) + :> (0x0A, 0x03, 0x1F) + :> (0x0A, 0x04, 0x00) + :> (0x0A, 0x05, 0x1F) + :> (0x0A, 0x14, 0x00) + :> (0x0A, 0x1A, 0x00) + :> (0x0A, 0x20, 0x00) + :> (0x0A, 0x26, 0x00) + :> (0x0A, 0x2C, 0x00) + :> (0x0A, 0x38, 0x00) + :> (0x0A, 0x39, 0x00) + :> (0x0A, 0x3A, 0x00) + :> (0x0A, 0x3C, 0x00) + :> (0x0A, 0x3D, 0x00) + :> (0x0A, 0x3E, 0x00) + :> (0x0A, 0x40, 0x00) + :> (0x0A, 0x41, 0x00) + :> (0x0A, 0x42, 0x00) + :> (0x0A, 0x44, 0x00) + :> (0x0A, 0x45, 0x00) + :> (0x0A, 0x46, 0x00) + :> (0x0A, 0x48, 0x00) + :> (0x0A, 0x49, 0x00) + :> (0x0A, 0x4A, 0x00) + :> (0x0A, 0x4C, 0x00) + :> (0x0A, 0x4D, 0x00) + :> (0x0A, 0x4E, 0x00) + :> (0x0A, 0x4F, 0x00) + :> (0x0A, 0x50, 0x00) + :> (0x0A, 0x51, 0x00) + :> (0x0A, 0x52, 0x00) + :> (0x0A, 0x53, 0x00) + :> (0x0A, 0x54, 0x00) + :> (0x0A, 0x55, 0x00) + :> (0x0A, 0x56, 0x00) + :> (0x0A, 0x57, 0x00) + :> (0x0A, 0x58, 0x00) + :> (0x0A, 0x59, 0x00) + :> (0x0A, 0x5A, 0x00) + :> (0x0A, 0x5B, 0x00) + :> (0x0A, 0x5C, 0x00) + :> (0x0A, 0x5D, 0x00) + :> (0x0A, 0x5E, 0x00) + :> (0x0A, 0x5F, 0x00) + :> (0x0B, 0x44, 0x00) + :> (0x0B, 0x4A, 0x00) + :> (0x0B, 0x57, 0x0E) + :> (0x0B, 0x58, 0x01) + :> Nil --- | Configuration for Si5391A with all output clocks enabled at 200MHz and routed through --- divider N0. +{- | Configuration for Si5391A with all output clocks enabled at 200MHz and routed through +divider N0. +-} testConfigB :: Si5391ARegisterMap testConfigB = Si539xRegisterMap{..} where configPreamble = (0x0B, 0x24, 0xC0) :> (0x0B, 0x25, 0x00) :> Nil configPostamble = (0x00, 0x1C, 0x01) :> (0x0B, 0x24, 0xC3) :> (0x0B, 0x25, 0x02) :> Nil config = - (0x00, 0x06, 0x00) :> - (0x00, 0x07, 0x00) :> - (0x00, 0x08, 0x00) :> - (0x00, 0x0B, 0x74) :> - (0x00, 0x17, 0xD0) :> - (0x00, 0x18, 0xFF) :> - (0x00, 0x21, 0x0F) :> - (0x00, 0x22, 0x00) :> - (0x00, 0x2B, 0x02) :> - (0x00, 0x2C, 0x20) :> - (0x00, 0x2D, 0x00) :> - (0x00, 0x2E, 0x00) :> - (0x00, 0x2F, 0x00) :> - (0x00, 0x30, 0x00) :> - (0x00, 0x31, 0x00) :> - (0x00, 0x32, 0x00) :> - (0x00, 0x33, 0x00) :> - (0x00, 0x34, 0x00) :> - (0x00, 0x35, 0x00) :> - (0x00, 0x36, 0x00) :> - (0x00, 0x37, 0x00) :> - (0x00, 0x38, 0x00) :> - (0x00, 0x39, 0x00) :> - (0x00, 0x3A, 0x00) :> - (0x00, 0x3B, 0x00) :> - (0x00, 0x3C, 0x00) :> - (0x00, 0x3D, 0x00) :> - (0x00, 0x41, 0x00) :> - (0x00, 0x42, 0x00) :> - (0x00, 0x43, 0x00) :> - (0x00, 0x44, 0x00) :> - (0x00, 0x9E, 0x00) :> - (0x01, 0x02, 0x01) :> - (0x01, 0x03, 0x06) :> - (0x01, 0x04, 0x09) :> - (0x01, 0x05, 0x3E) :> - (0x01, 0x06, 0x18) :> - (0x01, 0x08, 0x06) :> - (0x01, 0x09, 0x09) :> - (0x01, 0x0A, 0x3E) :> - (0x01, 0x0B, 0x18) :> - (0x01, 0x0D, 0x06) :> - (0x01, 0x0E, 0x09) :> - (0x01, 0x0F, 0x3E) :> - (0x01, 0x10, 0x18) :> - (0x01, 0x12, 0x06) :> - (0x01, 0x13, 0x09) :> - (0x01, 0x14, 0x3E) :> - (0x01, 0x15, 0x18) :> - (0x01, 0x17, 0x06) :> - (0x01, 0x18, 0x09) :> - (0x01, 0x19, 0x3E) :> - (0x01, 0x1A, 0x18) :> - (0x01, 0x1C, 0x06) :> - (0x01, 0x1D, 0x09) :> - (0x01, 0x1E, 0x3E) :> - (0x01, 0x1F, 0x18) :> - (0x01, 0x21, 0x06) :> - (0x01, 0x22, 0x09) :> - (0x01, 0x23, 0x3E) :> - (0x01, 0x24, 0x18) :> - (0x01, 0x26, 0x06) :> - (0x01, 0x27, 0x09) :> - (0x01, 0x28, 0x3E) :> - (0x01, 0x29, 0x18) :> - (0x01, 0x2B, 0x06) :> - (0x01, 0x2C, 0x09) :> - (0x01, 0x2D, 0x3E) :> - (0x01, 0x2E, 0x18) :> - (0x01, 0x30, 0x06) :> - (0x01, 0x31, 0x09) :> - (0x01, 0x32, 0x3E) :> - (0x01, 0x33, 0x18) :> - (0x01, 0x35, 0x06) :> - (0x01, 0x36, 0x09) :> - (0x01, 0x37, 0x3E) :> - (0x01, 0x38, 0x18) :> - (0x01, 0x3A, 0x06) :> - (0x01, 0x3B, 0x09) :> - (0x01, 0x3C, 0x3E) :> - (0x01, 0x3D, 0x18) :> - (0x01, 0x3F, 0x00) :> - (0x01, 0x40, 0x00) :> - (0x01, 0x41, 0x40) :> - (0x02, 0x06, 0x00) :> - (0x02, 0x08, 0x00) :> - (0x02, 0x09, 0x00) :> - (0x02, 0x0A, 0x00) :> - (0x02, 0x0B, 0x00) :> - (0x02, 0x0C, 0x00) :> - (0x02, 0x0D, 0x00) :> - (0x02, 0x0E, 0x00) :> - (0x02, 0x0F, 0x00) :> - (0x02, 0x10, 0x00) :> - (0x02, 0x11, 0x00) :> - (0x02, 0x12, 0x00) :> - (0x02, 0x13, 0x00) :> - (0x02, 0x14, 0x00) :> - (0x02, 0x15, 0x00) :> - (0x02, 0x16, 0x00) :> - (0x02, 0x17, 0x00) :> - (0x02, 0x18, 0x00) :> - (0x02, 0x19, 0x00) :> - (0x02, 0x1A, 0x00) :> - (0x02, 0x1B, 0x00) :> - (0x02, 0x1C, 0x00) :> - (0x02, 0x1D, 0x00) :> - (0x02, 0x1E, 0x00) :> - (0x02, 0x1F, 0x00) :> - (0x02, 0x20, 0x00) :> - (0x02, 0x21, 0x00) :> - (0x02, 0x22, 0x00) :> - (0x02, 0x23, 0x00) :> - (0x02, 0x24, 0x00) :> - (0x02, 0x25, 0x00) :> - (0x02, 0x26, 0x00) :> - (0x02, 0x27, 0x00) :> - (0x02, 0x28, 0x00) :> - (0x02, 0x29, 0x00) :> - (0x02, 0x2A, 0x00) :> - (0x02, 0x2B, 0x00) :> - (0x02, 0x2C, 0x00) :> - (0x02, 0x2D, 0x00) :> - (0x02, 0x2E, 0x00) :> - (0x02, 0x2F, 0x00) :> - (0x02, 0x35, 0x00) :> - (0x02, 0x36, 0x00) :> - (0x02, 0x37, 0x00) :> - (0x02, 0x38, 0xC0) :> - (0x02, 0x39, 0x89) :> - (0x02, 0x3A, 0x00) :> - (0x02, 0x3B, 0x00) :> - (0x02, 0x3C, 0x00) :> - (0x02, 0x3D, 0x00) :> - (0x02, 0x3E, 0x80) :> - (0x02, 0x47, 0x00) :> - (0x02, 0x48, 0x00) :> - (0x02, 0x49, 0x00) :> - (0x02, 0x4A, 0x00) :> - (0x02, 0x4B, 0x00) :> - (0x02, 0x4C, 0x00) :> - (0x02, 0x4D, 0x00) :> - (0x02, 0x4E, 0x00) :> - (0x02, 0x4F, 0x00) :> - (0x02, 0x50, 0x00) :> - (0x02, 0x51, 0x00) :> - (0x02, 0x52, 0x00) :> - (0x02, 0x53, 0x00) :> - (0x02, 0x54, 0x00) :> - (0x02, 0x55, 0x00) :> - (0x02, 0x56, 0x00) :> - (0x02, 0x57, 0x00) :> - (0x02, 0x58, 0x00) :> - (0x02, 0x59, 0x00) :> - (0x02, 0x5A, 0x00) :> - (0x02, 0x5B, 0x00) :> - (0x02, 0x5C, 0x00) :> - (0x02, 0x5D, 0x00) :> - (0x02, 0x5E, 0x00) :> - (0x02, 0x5F, 0x00) :> - (0x02, 0x60, 0x00) :> - (0x02, 0x61, 0x00) :> - (0x02, 0x62, 0x00) :> - (0x02, 0x63, 0x00) :> - (0x02, 0x64, 0x00) :> - (0x02, 0x65, 0x00) :> - (0x02, 0x66, 0x00) :> - (0x02, 0x67, 0x00) :> - (0x02, 0x68, 0x00) :> - (0x02, 0x69, 0x00) :> - (0x02, 0x6A, 0x00) :> - (0x02, 0x6B, 0x35) :> - (0x02, 0x6C, 0x33) :> - (0x02, 0x6D, 0x39) :> - (0x02, 0x6E, 0x31) :> - (0x02, 0x6F, 0x41) :> - (0x02, 0x70, 0x45) :> - (0x02, 0x71, 0x56) :> - (0x02, 0x72, 0x42) :> - (0x03, 0x02, 0x00) :> - (0x03, 0x03, 0x00) :> - (0x03, 0x04, 0x00) :> - (0x03, 0x05, 0xD4) :> - (0x03, 0x06, 0x19) :> - (0x03, 0x07, 0x00) :> - (0x03, 0x08, 0x00) :> - (0x03, 0x09, 0x00) :> - (0x03, 0x0A, 0x00) :> - (0x03, 0x0B, 0xC8) :> - (0x03, 0x0C, 0x00) :> - (0x03, 0x0D, 0x00) :> - (0x03, 0x0E, 0x00) :> - (0x03, 0x0F, 0x00) :> - (0x03, 0x10, 0x00) :> - (0x03, 0x11, 0x00) :> - (0x03, 0x12, 0x00) :> - (0x03, 0x13, 0x00) :> - (0x03, 0x14, 0x00) :> - (0x03, 0x15, 0x00) :> - (0x03, 0x16, 0x00) :> - (0x03, 0x17, 0x00) :> - (0x03, 0x18, 0x00) :> - (0x03, 0x19, 0x00) :> - (0x03, 0x1A, 0x00) :> - (0x03, 0x1B, 0x00) :> - (0x03, 0x1C, 0x00) :> - (0x03, 0x1D, 0x00) :> - (0x03, 0x1E, 0x00) :> - (0x03, 0x1F, 0x00) :> - (0x03, 0x20, 0x00) :> - (0x03, 0x21, 0x00) :> - (0x03, 0x22, 0x00) :> - (0x03, 0x23, 0x00) :> - (0x03, 0x24, 0x00) :> - (0x03, 0x25, 0x00) :> - (0x03, 0x26, 0x00) :> - (0x03, 0x27, 0x00) :> - (0x03, 0x28, 0x00) :> - (0x03, 0x29, 0x00) :> - (0x03, 0x2A, 0x00) :> - (0x03, 0x2B, 0x00) :> - (0x03, 0x2C, 0x00) :> - (0x03, 0x2D, 0x00) :> - (0x03, 0x2E, 0x00) :> - (0x03, 0x2F, 0x00) :> - (0x03, 0x30, 0x00) :> - (0x03, 0x31, 0x00) :> - (0x03, 0x32, 0x00) :> - (0x03, 0x33, 0x00) :> - (0x03, 0x34, 0x00) :> - (0x03, 0x35, 0x00) :> - (0x03, 0x36, 0x00) :> - (0x03, 0x37, 0x00) :> - (0x03, 0x38, 0x00) :> - (0x03, 0x39, 0x1E) :> - (0x03, 0x3B, 0x53) :> - (0x03, 0x3C, 0xB1) :> - (0x03, 0x3D, 0x01) :> - (0x03, 0x3E, 0x00) :> - (0x03, 0x3F, 0x00) :> - (0x03, 0x40, 0x00) :> - (0x03, 0x41, 0x00) :> - (0x03, 0x42, 0x00) :> - (0x03, 0x43, 0x00) :> - (0x03, 0x44, 0x00) :> - (0x03, 0x45, 0x00) :> - (0x03, 0x46, 0x00) :> - (0x03, 0x47, 0x00) :> - (0x03, 0x48, 0x00) :> - (0x03, 0x49, 0x00) :> - (0x03, 0x4A, 0x00) :> - (0x03, 0x4B, 0x00) :> - (0x03, 0x4C, 0x00) :> - (0x03, 0x4D, 0x00) :> - (0x03, 0x4E, 0x00) :> - (0x03, 0x4F, 0x00) :> - (0x03, 0x50, 0x00) :> - (0x03, 0x51, 0x00) :> - (0x03, 0x52, 0x00) :> - (0x03, 0x53, 0x00) :> - (0x03, 0x54, 0x00) :> - (0x03, 0x55, 0x00) :> - (0x03, 0x56, 0x00) :> - (0x03, 0x57, 0x00) :> - (0x03, 0x58, 0x00) :> - (0x03, 0x59, 0x00) :> - (0x03, 0x5A, 0x00) :> - (0x03, 0x5B, 0x00) :> - (0x03, 0x5C, 0x00) :> - (0x03, 0x5D, 0x00) :> - (0x03, 0x5E, 0x00) :> - (0x03, 0x5F, 0x00) :> - (0x03, 0x60, 0x00) :> - (0x03, 0x61, 0x00) :> - (0x03, 0x62, 0x00) :> - (0x08, 0x02, 0x00) :> - (0x08, 0x03, 0x00) :> - (0x08, 0x04, 0x00) :> - (0x08, 0x05, 0x00) :> - (0x08, 0x06, 0x00) :> - (0x08, 0x07, 0x00) :> - (0x08, 0x08, 0x00) :> - (0x08, 0x09, 0x00) :> - (0x08, 0x0A, 0x00) :> - (0x08, 0x0B, 0x00) :> - (0x08, 0x0C, 0x00) :> - (0x08, 0x0D, 0x00) :> - (0x08, 0x0E, 0x00) :> - (0x08, 0x0F, 0x00) :> - (0x08, 0x10, 0x00) :> - (0x08, 0x11, 0x00) :> - (0x08, 0x12, 0x00) :> - (0x08, 0x13, 0x00) :> - (0x08, 0x14, 0x00) :> - (0x08, 0x15, 0x00) :> - (0x08, 0x16, 0x00) :> - (0x08, 0x17, 0x00) :> - (0x08, 0x18, 0x00) :> - (0x08, 0x19, 0x00) :> - (0x08, 0x1A, 0x00) :> - (0x08, 0x1B, 0x00) :> - (0x08, 0x1C, 0x00) :> - (0x08, 0x1D, 0x00) :> - (0x08, 0x1E, 0x00) :> - (0x08, 0x1F, 0x00) :> - (0x08, 0x20, 0x00) :> - (0x08, 0x21, 0x00) :> - (0x08, 0x22, 0x00) :> - (0x08, 0x23, 0x00) :> - (0x08, 0x24, 0x00) :> - (0x08, 0x25, 0x00) :> - (0x08, 0x26, 0x00) :> - (0x08, 0x27, 0x00) :> - (0x08, 0x28, 0x00) :> - (0x08, 0x29, 0x00) :> - (0x08, 0x2A, 0x00) :> - (0x08, 0x2B, 0x00) :> - (0x08, 0x2C, 0x00) :> - (0x08, 0x2D, 0x00) :> - (0x08, 0x2E, 0x00) :> - (0x08, 0x2F, 0x00) :> - (0x08, 0x30, 0x00) :> - (0x08, 0x31, 0x00) :> - (0x08, 0x32, 0x00) :> - (0x08, 0x33, 0x00) :> - (0x08, 0x34, 0x00) :> - (0x08, 0x35, 0x00) :> - (0x08, 0x36, 0x00) :> - (0x08, 0x37, 0x00) :> - (0x08, 0x38, 0x00) :> - (0x08, 0x39, 0x00) :> - (0x08, 0x3A, 0x00) :> - (0x08, 0x3B, 0x00) :> - (0x08, 0x3C, 0x00) :> - (0x08, 0x3D, 0x00) :> - (0x08, 0x3E, 0x00) :> - (0x08, 0x3F, 0x00) :> - (0x08, 0x40, 0x00) :> - (0x08, 0x41, 0x00) :> - (0x08, 0x42, 0x00) :> - (0x08, 0x43, 0x00) :> - (0x08, 0x44, 0x00) :> - (0x08, 0x45, 0x00) :> - (0x08, 0x46, 0x00) :> - (0x08, 0x47, 0x00) :> - (0x08, 0x48, 0x00) :> - (0x08, 0x49, 0x00) :> - (0x08, 0x4A, 0x00) :> - (0x08, 0x4B, 0x00) :> - (0x08, 0x4C, 0x00) :> - (0x08, 0x4D, 0x00) :> - (0x08, 0x4E, 0x00) :> - (0x08, 0x4F, 0x00) :> - (0x08, 0x50, 0x00) :> - (0x08, 0x51, 0x00) :> - (0x08, 0x52, 0x00) :> - (0x08, 0x53, 0x00) :> - (0x08, 0x54, 0x00) :> - (0x08, 0x55, 0x00) :> - (0x08, 0x56, 0x00) :> - (0x08, 0x57, 0x00) :> - (0x08, 0x58, 0x00) :> - (0x08, 0x59, 0x00) :> - (0x08, 0x5A, 0x00) :> - (0x08, 0x5B, 0x00) :> - (0x08, 0x5C, 0x00) :> - (0x08, 0x5D, 0x00) :> - (0x08, 0x5E, 0x00) :> - (0x08, 0x5F, 0x00) :> - (0x08, 0x60, 0x00) :> - (0x08, 0x61, 0x00) :> - (0x09, 0x0E, 0x02) :> - (0x09, 0x1C, 0x04) :> - (0x09, 0x43, 0x01) :> - (0x09, 0x49, 0x00) :> - (0x09, 0x4A, 0x00) :> - (0x09, 0x4E, 0x49) :> - (0x09, 0x4F, 0xF2) :> - (0x09, 0x5E, 0x00) :> - (0x0A, 0x02, 0x00) :> - (0x0A, 0x03, 0x01) :> - (0x0A, 0x04, 0x00) :> - (0x0A, 0x05, 0x01) :> - (0x0A, 0x14, 0x00) :> - (0x0A, 0x1A, 0x00) :> - (0x0A, 0x20, 0x00) :> - (0x0A, 0x26, 0x00) :> - (0x0A, 0x2C, 0x00) :> - (0x0A, 0x38, 0x00) :> - (0x0A, 0x39, 0x00) :> - (0x0A, 0x3A, 0x00) :> - (0x0A, 0x3C, 0x00) :> - (0x0A, 0x3D, 0x00) :> - (0x0A, 0x3E, 0x00) :> - (0x0A, 0x40, 0x00) :> - (0x0A, 0x41, 0x00) :> - (0x0A, 0x42, 0x00) :> - (0x0A, 0x44, 0x00) :> - (0x0A, 0x45, 0x00) :> - (0x0A, 0x46, 0x00) :> - (0x0A, 0x48, 0x00) :> - (0x0A, 0x49, 0x00) :> - (0x0A, 0x4A, 0x00) :> - (0x0A, 0x4C, 0x00) :> - (0x0A, 0x4D, 0x00) :> - (0x0A, 0x4E, 0x00) :> - (0x0A, 0x4F, 0x00) :> - (0x0A, 0x50, 0x00) :> - (0x0A, 0x51, 0x00) :> - (0x0A, 0x52, 0x00) :> - (0x0A, 0x53, 0x00) :> - (0x0A, 0x54, 0x00) :> - (0x0A, 0x55, 0x00) :> - (0x0A, 0x56, 0x00) :> - (0x0A, 0x57, 0x00) :> - (0x0A, 0x58, 0x00) :> - (0x0A, 0x59, 0x00) :> - (0x0A, 0x5A, 0x00) :> - (0x0A, 0x5B, 0x00) :> - (0x0A, 0x5C, 0x00) :> - (0x0A, 0x5D, 0x00) :> - (0x0A, 0x5E, 0x00) :> - (0x0A, 0x5F, 0x00) :> - (0x0B, 0x44, 0x0F) :> - (0x0B, 0x4A, 0x1E) :> - (0x0B, 0x57, 0x0E) :> - (0x0B, 0x58, 0x01) :> Nil + (0x00, 0x06, 0x00) + :> (0x00, 0x07, 0x00) + :> (0x00, 0x08, 0x00) + :> (0x00, 0x0B, 0x74) + :> (0x00, 0x17, 0xD0) + :> (0x00, 0x18, 0xFF) + :> (0x00, 0x21, 0x0F) + :> (0x00, 0x22, 0x00) + :> (0x00, 0x2B, 0x02) + :> (0x00, 0x2C, 0x20) + :> (0x00, 0x2D, 0x00) + :> (0x00, 0x2E, 0x00) + :> (0x00, 0x2F, 0x00) + :> (0x00, 0x30, 0x00) + :> (0x00, 0x31, 0x00) + :> (0x00, 0x32, 0x00) + :> (0x00, 0x33, 0x00) + :> (0x00, 0x34, 0x00) + :> (0x00, 0x35, 0x00) + :> (0x00, 0x36, 0x00) + :> (0x00, 0x37, 0x00) + :> (0x00, 0x38, 0x00) + :> (0x00, 0x39, 0x00) + :> (0x00, 0x3A, 0x00) + :> (0x00, 0x3B, 0x00) + :> (0x00, 0x3C, 0x00) + :> (0x00, 0x3D, 0x00) + :> (0x00, 0x41, 0x00) + :> (0x00, 0x42, 0x00) + :> (0x00, 0x43, 0x00) + :> (0x00, 0x44, 0x00) + :> (0x00, 0x9E, 0x00) + :> (0x01, 0x02, 0x01) + :> (0x01, 0x03, 0x06) + :> (0x01, 0x04, 0x09) + :> (0x01, 0x05, 0x3E) + :> (0x01, 0x06, 0x18) + :> (0x01, 0x08, 0x06) + :> (0x01, 0x09, 0x09) + :> (0x01, 0x0A, 0x3E) + :> (0x01, 0x0B, 0x18) + :> (0x01, 0x0D, 0x06) + :> (0x01, 0x0E, 0x09) + :> (0x01, 0x0F, 0x3E) + :> (0x01, 0x10, 0x18) + :> (0x01, 0x12, 0x06) + :> (0x01, 0x13, 0x09) + :> (0x01, 0x14, 0x3E) + :> (0x01, 0x15, 0x18) + :> (0x01, 0x17, 0x06) + :> (0x01, 0x18, 0x09) + :> (0x01, 0x19, 0x3E) + :> (0x01, 0x1A, 0x18) + :> (0x01, 0x1C, 0x06) + :> (0x01, 0x1D, 0x09) + :> (0x01, 0x1E, 0x3E) + :> (0x01, 0x1F, 0x18) + :> (0x01, 0x21, 0x06) + :> (0x01, 0x22, 0x09) + :> (0x01, 0x23, 0x3E) + :> (0x01, 0x24, 0x18) + :> (0x01, 0x26, 0x06) + :> (0x01, 0x27, 0x09) + :> (0x01, 0x28, 0x3E) + :> (0x01, 0x29, 0x18) + :> (0x01, 0x2B, 0x06) + :> (0x01, 0x2C, 0x09) + :> (0x01, 0x2D, 0x3E) + :> (0x01, 0x2E, 0x18) + :> (0x01, 0x30, 0x06) + :> (0x01, 0x31, 0x09) + :> (0x01, 0x32, 0x3E) + :> (0x01, 0x33, 0x18) + :> (0x01, 0x35, 0x06) + :> (0x01, 0x36, 0x09) + :> (0x01, 0x37, 0x3E) + :> (0x01, 0x38, 0x18) + :> (0x01, 0x3A, 0x06) + :> (0x01, 0x3B, 0x09) + :> (0x01, 0x3C, 0x3E) + :> (0x01, 0x3D, 0x18) + :> (0x01, 0x3F, 0x00) + :> (0x01, 0x40, 0x00) + :> (0x01, 0x41, 0x40) + :> (0x02, 0x06, 0x00) + :> (0x02, 0x08, 0x00) + :> (0x02, 0x09, 0x00) + :> (0x02, 0x0A, 0x00) + :> (0x02, 0x0B, 0x00) + :> (0x02, 0x0C, 0x00) + :> (0x02, 0x0D, 0x00) + :> (0x02, 0x0E, 0x00) + :> (0x02, 0x0F, 0x00) + :> (0x02, 0x10, 0x00) + :> (0x02, 0x11, 0x00) + :> (0x02, 0x12, 0x00) + :> (0x02, 0x13, 0x00) + :> (0x02, 0x14, 0x00) + :> (0x02, 0x15, 0x00) + :> (0x02, 0x16, 0x00) + :> (0x02, 0x17, 0x00) + :> (0x02, 0x18, 0x00) + :> (0x02, 0x19, 0x00) + :> (0x02, 0x1A, 0x00) + :> (0x02, 0x1B, 0x00) + :> (0x02, 0x1C, 0x00) + :> (0x02, 0x1D, 0x00) + :> (0x02, 0x1E, 0x00) + :> (0x02, 0x1F, 0x00) + :> (0x02, 0x20, 0x00) + :> (0x02, 0x21, 0x00) + :> (0x02, 0x22, 0x00) + :> (0x02, 0x23, 0x00) + :> (0x02, 0x24, 0x00) + :> (0x02, 0x25, 0x00) + :> (0x02, 0x26, 0x00) + :> (0x02, 0x27, 0x00) + :> (0x02, 0x28, 0x00) + :> (0x02, 0x29, 0x00) + :> (0x02, 0x2A, 0x00) + :> (0x02, 0x2B, 0x00) + :> (0x02, 0x2C, 0x00) + :> (0x02, 0x2D, 0x00) + :> (0x02, 0x2E, 0x00) + :> (0x02, 0x2F, 0x00) + :> (0x02, 0x35, 0x00) + :> (0x02, 0x36, 0x00) + :> (0x02, 0x37, 0x00) + :> (0x02, 0x38, 0xC0) + :> (0x02, 0x39, 0x89) + :> (0x02, 0x3A, 0x00) + :> (0x02, 0x3B, 0x00) + :> (0x02, 0x3C, 0x00) + :> (0x02, 0x3D, 0x00) + :> (0x02, 0x3E, 0x80) + :> (0x02, 0x47, 0x00) + :> (0x02, 0x48, 0x00) + :> (0x02, 0x49, 0x00) + :> (0x02, 0x4A, 0x00) + :> (0x02, 0x4B, 0x00) + :> (0x02, 0x4C, 0x00) + :> (0x02, 0x4D, 0x00) + :> (0x02, 0x4E, 0x00) + :> (0x02, 0x4F, 0x00) + :> (0x02, 0x50, 0x00) + :> (0x02, 0x51, 0x00) + :> (0x02, 0x52, 0x00) + :> (0x02, 0x53, 0x00) + :> (0x02, 0x54, 0x00) + :> (0x02, 0x55, 0x00) + :> (0x02, 0x56, 0x00) + :> (0x02, 0x57, 0x00) + :> (0x02, 0x58, 0x00) + :> (0x02, 0x59, 0x00) + :> (0x02, 0x5A, 0x00) + :> (0x02, 0x5B, 0x00) + :> (0x02, 0x5C, 0x00) + :> (0x02, 0x5D, 0x00) + :> (0x02, 0x5E, 0x00) + :> (0x02, 0x5F, 0x00) + :> (0x02, 0x60, 0x00) + :> (0x02, 0x61, 0x00) + :> (0x02, 0x62, 0x00) + :> (0x02, 0x63, 0x00) + :> (0x02, 0x64, 0x00) + :> (0x02, 0x65, 0x00) + :> (0x02, 0x66, 0x00) + :> (0x02, 0x67, 0x00) + :> (0x02, 0x68, 0x00) + :> (0x02, 0x69, 0x00) + :> (0x02, 0x6A, 0x00) + :> (0x02, 0x6B, 0x35) + :> (0x02, 0x6C, 0x33) + :> (0x02, 0x6D, 0x39) + :> (0x02, 0x6E, 0x31) + :> (0x02, 0x6F, 0x41) + :> (0x02, 0x70, 0x45) + :> (0x02, 0x71, 0x56) + :> (0x02, 0x72, 0x42) + :> (0x03, 0x02, 0x00) + :> (0x03, 0x03, 0x00) + :> (0x03, 0x04, 0x00) + :> (0x03, 0x05, 0xD4) + :> (0x03, 0x06, 0x19) + :> (0x03, 0x07, 0x00) + :> (0x03, 0x08, 0x00) + :> (0x03, 0x09, 0x00) + :> (0x03, 0x0A, 0x00) + :> (0x03, 0x0B, 0xC8) + :> (0x03, 0x0C, 0x00) + :> (0x03, 0x0D, 0x00) + :> (0x03, 0x0E, 0x00) + :> (0x03, 0x0F, 0x00) + :> (0x03, 0x10, 0x00) + :> (0x03, 0x11, 0x00) + :> (0x03, 0x12, 0x00) + :> (0x03, 0x13, 0x00) + :> (0x03, 0x14, 0x00) + :> (0x03, 0x15, 0x00) + :> (0x03, 0x16, 0x00) + :> (0x03, 0x17, 0x00) + :> (0x03, 0x18, 0x00) + :> (0x03, 0x19, 0x00) + :> (0x03, 0x1A, 0x00) + :> (0x03, 0x1B, 0x00) + :> (0x03, 0x1C, 0x00) + :> (0x03, 0x1D, 0x00) + :> (0x03, 0x1E, 0x00) + :> (0x03, 0x1F, 0x00) + :> (0x03, 0x20, 0x00) + :> (0x03, 0x21, 0x00) + :> (0x03, 0x22, 0x00) + :> (0x03, 0x23, 0x00) + :> (0x03, 0x24, 0x00) + :> (0x03, 0x25, 0x00) + :> (0x03, 0x26, 0x00) + :> (0x03, 0x27, 0x00) + :> (0x03, 0x28, 0x00) + :> (0x03, 0x29, 0x00) + :> (0x03, 0x2A, 0x00) + :> (0x03, 0x2B, 0x00) + :> (0x03, 0x2C, 0x00) + :> (0x03, 0x2D, 0x00) + :> (0x03, 0x2E, 0x00) + :> (0x03, 0x2F, 0x00) + :> (0x03, 0x30, 0x00) + :> (0x03, 0x31, 0x00) + :> (0x03, 0x32, 0x00) + :> (0x03, 0x33, 0x00) + :> (0x03, 0x34, 0x00) + :> (0x03, 0x35, 0x00) + :> (0x03, 0x36, 0x00) + :> (0x03, 0x37, 0x00) + :> (0x03, 0x38, 0x00) + :> (0x03, 0x39, 0x1E) + :> (0x03, 0x3B, 0x53) + :> (0x03, 0x3C, 0xB1) + :> (0x03, 0x3D, 0x01) + :> (0x03, 0x3E, 0x00) + :> (0x03, 0x3F, 0x00) + :> (0x03, 0x40, 0x00) + :> (0x03, 0x41, 0x00) + :> (0x03, 0x42, 0x00) + :> (0x03, 0x43, 0x00) + :> (0x03, 0x44, 0x00) + :> (0x03, 0x45, 0x00) + :> (0x03, 0x46, 0x00) + :> (0x03, 0x47, 0x00) + :> (0x03, 0x48, 0x00) + :> (0x03, 0x49, 0x00) + :> (0x03, 0x4A, 0x00) + :> (0x03, 0x4B, 0x00) + :> (0x03, 0x4C, 0x00) + :> (0x03, 0x4D, 0x00) + :> (0x03, 0x4E, 0x00) + :> (0x03, 0x4F, 0x00) + :> (0x03, 0x50, 0x00) + :> (0x03, 0x51, 0x00) + :> (0x03, 0x52, 0x00) + :> (0x03, 0x53, 0x00) + :> (0x03, 0x54, 0x00) + :> (0x03, 0x55, 0x00) + :> (0x03, 0x56, 0x00) + :> (0x03, 0x57, 0x00) + :> (0x03, 0x58, 0x00) + :> (0x03, 0x59, 0x00) + :> (0x03, 0x5A, 0x00) + :> (0x03, 0x5B, 0x00) + :> (0x03, 0x5C, 0x00) + :> (0x03, 0x5D, 0x00) + :> (0x03, 0x5E, 0x00) + :> (0x03, 0x5F, 0x00) + :> (0x03, 0x60, 0x00) + :> (0x03, 0x61, 0x00) + :> (0x03, 0x62, 0x00) + :> (0x08, 0x02, 0x00) + :> (0x08, 0x03, 0x00) + :> (0x08, 0x04, 0x00) + :> (0x08, 0x05, 0x00) + :> (0x08, 0x06, 0x00) + :> (0x08, 0x07, 0x00) + :> (0x08, 0x08, 0x00) + :> (0x08, 0x09, 0x00) + :> (0x08, 0x0A, 0x00) + :> (0x08, 0x0B, 0x00) + :> (0x08, 0x0C, 0x00) + :> (0x08, 0x0D, 0x00) + :> (0x08, 0x0E, 0x00) + :> (0x08, 0x0F, 0x00) + :> (0x08, 0x10, 0x00) + :> (0x08, 0x11, 0x00) + :> (0x08, 0x12, 0x00) + :> (0x08, 0x13, 0x00) + :> (0x08, 0x14, 0x00) + :> (0x08, 0x15, 0x00) + :> (0x08, 0x16, 0x00) + :> (0x08, 0x17, 0x00) + :> (0x08, 0x18, 0x00) + :> (0x08, 0x19, 0x00) + :> (0x08, 0x1A, 0x00) + :> (0x08, 0x1B, 0x00) + :> (0x08, 0x1C, 0x00) + :> (0x08, 0x1D, 0x00) + :> (0x08, 0x1E, 0x00) + :> (0x08, 0x1F, 0x00) + :> (0x08, 0x20, 0x00) + :> (0x08, 0x21, 0x00) + :> (0x08, 0x22, 0x00) + :> (0x08, 0x23, 0x00) + :> (0x08, 0x24, 0x00) + :> (0x08, 0x25, 0x00) + :> (0x08, 0x26, 0x00) + :> (0x08, 0x27, 0x00) + :> (0x08, 0x28, 0x00) + :> (0x08, 0x29, 0x00) + :> (0x08, 0x2A, 0x00) + :> (0x08, 0x2B, 0x00) + :> (0x08, 0x2C, 0x00) + :> (0x08, 0x2D, 0x00) + :> (0x08, 0x2E, 0x00) + :> (0x08, 0x2F, 0x00) + :> (0x08, 0x30, 0x00) + :> (0x08, 0x31, 0x00) + :> (0x08, 0x32, 0x00) + :> (0x08, 0x33, 0x00) + :> (0x08, 0x34, 0x00) + :> (0x08, 0x35, 0x00) + :> (0x08, 0x36, 0x00) + :> (0x08, 0x37, 0x00) + :> (0x08, 0x38, 0x00) + :> (0x08, 0x39, 0x00) + :> (0x08, 0x3A, 0x00) + :> (0x08, 0x3B, 0x00) + :> (0x08, 0x3C, 0x00) + :> (0x08, 0x3D, 0x00) + :> (0x08, 0x3E, 0x00) + :> (0x08, 0x3F, 0x00) + :> (0x08, 0x40, 0x00) + :> (0x08, 0x41, 0x00) + :> (0x08, 0x42, 0x00) + :> (0x08, 0x43, 0x00) + :> (0x08, 0x44, 0x00) + :> (0x08, 0x45, 0x00) + :> (0x08, 0x46, 0x00) + :> (0x08, 0x47, 0x00) + :> (0x08, 0x48, 0x00) + :> (0x08, 0x49, 0x00) + :> (0x08, 0x4A, 0x00) + :> (0x08, 0x4B, 0x00) + :> (0x08, 0x4C, 0x00) + :> (0x08, 0x4D, 0x00) + :> (0x08, 0x4E, 0x00) + :> (0x08, 0x4F, 0x00) + :> (0x08, 0x50, 0x00) + :> (0x08, 0x51, 0x00) + :> (0x08, 0x52, 0x00) + :> (0x08, 0x53, 0x00) + :> (0x08, 0x54, 0x00) + :> (0x08, 0x55, 0x00) + :> (0x08, 0x56, 0x00) + :> (0x08, 0x57, 0x00) + :> (0x08, 0x58, 0x00) + :> (0x08, 0x59, 0x00) + :> (0x08, 0x5A, 0x00) + :> (0x08, 0x5B, 0x00) + :> (0x08, 0x5C, 0x00) + :> (0x08, 0x5D, 0x00) + :> (0x08, 0x5E, 0x00) + :> (0x08, 0x5F, 0x00) + :> (0x08, 0x60, 0x00) + :> (0x08, 0x61, 0x00) + :> (0x09, 0x0E, 0x02) + :> (0x09, 0x1C, 0x04) + :> (0x09, 0x43, 0x01) + :> (0x09, 0x49, 0x00) + :> (0x09, 0x4A, 0x00) + :> (0x09, 0x4E, 0x49) + :> (0x09, 0x4F, 0xF2) + :> (0x09, 0x5E, 0x00) + :> (0x0A, 0x02, 0x00) + :> (0x0A, 0x03, 0x01) + :> (0x0A, 0x04, 0x00) + :> (0x0A, 0x05, 0x01) + :> (0x0A, 0x14, 0x00) + :> (0x0A, 0x1A, 0x00) + :> (0x0A, 0x20, 0x00) + :> (0x0A, 0x26, 0x00) + :> (0x0A, 0x2C, 0x00) + :> (0x0A, 0x38, 0x00) + :> (0x0A, 0x39, 0x00) + :> (0x0A, 0x3A, 0x00) + :> (0x0A, 0x3C, 0x00) + :> (0x0A, 0x3D, 0x00) + :> (0x0A, 0x3E, 0x00) + :> (0x0A, 0x40, 0x00) + :> (0x0A, 0x41, 0x00) + :> (0x0A, 0x42, 0x00) + :> (0x0A, 0x44, 0x00) + :> (0x0A, 0x45, 0x00) + :> (0x0A, 0x46, 0x00) + :> (0x0A, 0x48, 0x00) + :> (0x0A, 0x49, 0x00) + :> (0x0A, 0x4A, 0x00) + :> (0x0A, 0x4C, 0x00) + :> (0x0A, 0x4D, 0x00) + :> (0x0A, 0x4E, 0x00) + :> (0x0A, 0x4F, 0x00) + :> (0x0A, 0x50, 0x00) + :> (0x0A, 0x51, 0x00) + :> (0x0A, 0x52, 0x00) + :> (0x0A, 0x53, 0x00) + :> (0x0A, 0x54, 0x00) + :> (0x0A, 0x55, 0x00) + :> (0x0A, 0x56, 0x00) + :> (0x0A, 0x57, 0x00) + :> (0x0A, 0x58, 0x00) + :> (0x0A, 0x59, 0x00) + :> (0x0A, 0x5A, 0x00) + :> (0x0A, 0x5B, 0x00) + :> (0x0A, 0x5C, 0x00) + :> (0x0A, 0x5D, 0x00) + :> (0x0A, 0x5E, 0x00) + :> (0x0A, 0x5F, 0x00) + :> (0x0B, 0x44, 0x0F) + :> (0x0B, 0x4A, 0x1E) + :> (0x0B, 0x57, 0x0E) + :> (0x0B, 0x58, 0x01) + :> Nil diff --git a/bittide/src/Bittide/ClockControl/Si5395J.hs b/bittide/src/Bittide/ClockControl/Si5395J.hs index 16b5c381e..a008566ee 100644 --- a/bittide/src/Bittide/ClockControl/Si5395J.hs +++ b/bittide/src/Bittide/ClockControl/Si5395J.hs @@ -2,24 +2,26 @@ -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE RecordWildCards #-} + module Bittide.ClockControl.Si5395J where -import Clash.Prelude -import Bittide.ClockControl.Si539xSpi import Bittide.ClockControl.ParseRegisters +import Bittide.ClockControl.Si539xSpi +import Clash.Prelude type Si5395RegisterMap = Si539xRegisterMap 3 584 5 -type TestConfig6_200_on_0a_RegisterMap = Si539xRegisterMap 3 590 5 -type TestConfig6_200_on_0a_TotalRegs = 3 + 590 + 5 +type TestConfig6_200_on_0a_RegisterMap = Si539xRegisterMap 3 590 5 +type TestConfig6_200_on_0a_TotalRegs = 3 + 590 + 5 --- | Configuration for Si5395J with the following configuration: --- --- out0a: 200MHz LVDS 1.8V --- out9: 12.5MHz LVDS 1.8V --- out9a: 200MHz LVDS 1.8V --- --- all of them doing 1ppb steps on Finc/Fdec +{- | Configuration for Si5395J with the following configuration: + + out0a: 200MHz LVDS 1.8V + out9: 12.5MHz LVDS 1.8V + out9a: 200MHz LVDS 1.8V + + all of them doing 1ppb steps on Finc/Fdec +-} testConfig6_200_on_0a_1ppb :: TestConfig6_200_on_0a_RegisterMap testConfig6_200_on_0a_1ppb = $(parseFromFileToRegisterMap "Si5395J-200MHz-1ppb-Registers") @@ -36,1193 +38,1205 @@ testConfig6_200_on_0a_1ppm :: TestConfig6_200_on_0a_RegisterMap testConfig6_200_on_0a_1ppm = $(parseFromFileToRegisterMap "Si5395J-200MHz-1ppm-Registers") -- | Configuration for Si5395J with out6 at 200MHz, 1ppm FSTEP and out3 at 20MHz, 0.1% FSTEP -testConfig6_200_5_20 :: Si5395RegisterMap +testConfig6_200_5_20 :: Si5395RegisterMap testConfig6_200_5_20 = Si539xRegisterMap{..} where configPreamble = (0x0B, 0x24, 0xC0) :> (0x0B, 0x25, 0x00) :> (0x05, 0x40, 0x01) :> Nil - configPostamble = (0x05, 0x14, 0x01) :> (0x00, 0x1C, 0x01) :> (0x05, 0x40, 0x00) :> (0x0B, 0x24, 0xC3) :> (0x0B, 0x25, 0x02) :> Nil + configPostamble = + (0x05, 0x14, 0x01) + :> (0x00, 0x1C, 0x01) + :> (0x05, 0x40, 0x00) + :> (0x0B, 0x24, 0xC3) + :> (0x0B, 0x25, 0x02) + :> Nil config = - (0x00, 0x06, 0x00) :> - (0x00, 0x07, 0x00) :> - (0x00, 0x08, 0x00) :> - (0x00, 0x0B, 0x68) :> - (0x00, 0x16, 0x02) :> - (0x00, 0x17, 0xDC) :> - (0x00, 0x18, 0xFF) :> - (0x00, 0x19, 0xFF) :> - (0x00, 0x1A, 0xFF) :> - (0x00, 0x2B, 0x02) :> - (0x00, 0x2C, 0x00) :> - (0x00, 0x2D, 0x00) :> - (0x00, 0x2E, 0x00) :> - (0x00, 0x2F, 0x00) :> - (0x00, 0x30, 0x00) :> - (0x00, 0x31, 0x00) :> - (0x00, 0x32, 0x00) :> - (0x00, 0x33, 0x00) :> - (0x00, 0x34, 0x00) :> - (0x00, 0x35, 0x00) :> - (0x00, 0x36, 0x00) :> - (0x00, 0x37, 0x00) :> - (0x00, 0x38, 0x00) :> - (0x00, 0x39, 0x00) :> - (0x00, 0x3A, 0x00) :> - (0x00, 0x3B, 0x00) :> - (0x00, 0x3C, 0x00) :> - (0x00, 0x3D, 0x00) :> - (0x00, 0x3E, 0x00) :> - (0x00, 0x3F, 0x00) :> - (0x00, 0x40, 0x04) :> - (0x00, 0x41, 0x00) :> - (0x00, 0x42, 0x00) :> - (0x00, 0x43, 0x00) :> - (0x00, 0x44, 0x00) :> - (0x00, 0x45, 0x0C) :> - (0x00, 0x46, 0x00) :> - (0x00, 0x47, 0x00) :> - (0x00, 0x48, 0x00) :> - (0x00, 0x49, 0x00) :> - (0x00, 0x4A, 0x00) :> - (0x00, 0x4B, 0x00) :> - (0x00, 0x4C, 0x00) :> - (0x00, 0x4D, 0x00) :> - (0x00, 0x4E, 0x00) :> - (0x00, 0x4F, 0x00) :> - (0x00, 0x50, 0x0F) :> - (0x00, 0x51, 0x00) :> - (0x00, 0x52, 0x00) :> - (0x00, 0x53, 0x00) :> - (0x00, 0x54, 0x00) :> - (0x00, 0x55, 0x00) :> - (0x00, 0x56, 0x00) :> - (0x00, 0x57, 0x00) :> - (0x00, 0x58, 0x00) :> - (0x00, 0x59, 0x00) :> - (0x00, 0x5A, 0x00) :> - (0x00, 0x5B, 0x00) :> - (0x00, 0x5C, 0x00) :> - (0x00, 0x5D, 0x00) :> - (0x00, 0x5E, 0x00) :> - (0x00, 0x5F, 0x00) :> - (0x00, 0x60, 0x00) :> - (0x00, 0x61, 0x00) :> - (0x00, 0x62, 0x00) :> - (0x00, 0x63, 0x00) :> - (0x00, 0x64, 0x00) :> - (0x00, 0x65, 0x00) :> - (0x00, 0x66, 0x00) :> - (0x00, 0x67, 0x00) :> - (0x00, 0x68, 0x00) :> - (0x00, 0x69, 0x00) :> - (0x00, 0x92, 0x00) :> - (0x00, 0x93, 0x00) :> - (0x00, 0x95, 0x00) :> - (0x00, 0x96, 0x00) :> - (0x00, 0x98, 0x00) :> - (0x00, 0x9A, 0x00) :> - (0x00, 0x9B, 0x00) :> - (0x00, 0x9D, 0x00) :> - (0x00, 0x9E, 0x00) :> - (0x00, 0xA0, 0x00) :> - (0x00, 0xA2, 0x00) :> - (0x00, 0xA9, 0x00) :> - (0x00, 0xAA, 0x00) :> - (0x00, 0xAB, 0x00) :> - (0x00, 0xAC, 0x00) :> - (0x00, 0xE5, 0x01) :> - (0x00, 0xEA, 0x00) :> - (0x00, 0xEB, 0x00) :> - (0x00, 0xEC, 0x00) :> - (0x00, 0xED, 0x00) :> - (0x01, 0x02, 0x01) :> - (0x01, 0x03, 0x01) :> - (0x01, 0x04, 0x09) :> - (0x01, 0x05, 0x3B) :> - (0x01, 0x06, 0x28) :> - (0x01, 0x08, 0x01) :> - (0x01, 0x09, 0x09) :> - (0x01, 0x0A, 0x3B) :> - (0x01, 0x0B, 0x28) :> - (0x01, 0x0D, 0x01) :> - (0x01, 0x0E, 0x09) :> - (0x01, 0x0F, 0x3B) :> - (0x01, 0x10, 0x28) :> - (0x01, 0x12, 0x01) :> - (0x01, 0x13, 0x09) :> - (0x01, 0x14, 0x3B) :> - (0x01, 0x15, 0x28) :> - (0x01, 0x17, 0x02) :> - (0x01, 0x18, 0xCC) :> - (0x01, 0x19, 0x00) :> - (0x01, 0x1A, 0x19) :> - (0x01, 0x1C, 0x01) :> - (0x01, 0x1D, 0x09) :> - (0x01, 0x1E, 0x3B) :> - (0x01, 0x1F, 0x28) :> - (0x01, 0x21, 0x01) :> - (0x01, 0x22, 0x09) :> - (0x01, 0x23, 0x3B) :> - (0x01, 0x24, 0x28) :> - (0x01, 0x26, 0x02) :> - (0x01, 0x27, 0x09) :> - (0x01, 0x28, 0x3E) :> - (0x01, 0x29, 0x18) :> - (0x01, 0x2B, 0x01) :> - (0x01, 0x2C, 0x09) :> - (0x01, 0x2D, 0x3B) :> - (0x01, 0x2E, 0x28) :> - (0x01, 0x30, 0x01) :> - (0x01, 0x31, 0x09) :> - (0x01, 0x32, 0x3B) :> - (0x01, 0x33, 0x28) :> - (0x01, 0x35, 0x01) :> - (0x01, 0x36, 0x09) :> - (0x01, 0x37, 0x3B) :> - (0x01, 0x38, 0x28) :> - (0x01, 0x3A, 0x01) :> - (0x01, 0x3B, 0x09) :> - (0x01, 0x3C, 0x3E) :> - (0x01, 0x3D, 0x18) :> - (0x01, 0x3F, 0x00) :> - (0x01, 0x40, 0x00) :> - (0x01, 0x41, 0x40) :> - (0x01, 0x42, 0xFF) :> - (0x02, 0x06, 0x00) :> - (0x02, 0x08, 0x00) :> - (0x02, 0x09, 0x00) :> - (0x02, 0x0A, 0x00) :> - (0x02, 0x0B, 0x00) :> - (0x02, 0x0C, 0x00) :> - (0x02, 0x0D, 0x00) :> - (0x02, 0x0E, 0x00) :> - (0x02, 0x0F, 0x00) :> - (0x02, 0x10, 0x00) :> - (0x02, 0x11, 0x00) :> - (0x02, 0x12, 0x00) :> - (0x02, 0x13, 0x00) :> - (0x02, 0x14, 0x00) :> - (0x02, 0x15, 0x00) :> - (0x02, 0x16, 0x00) :> - (0x02, 0x17, 0x00) :> - (0x02, 0x18, 0x00) :> - (0x02, 0x19, 0x00) :> - (0x02, 0x1A, 0x00) :> - (0x02, 0x1B, 0x00) :> - (0x02, 0x1C, 0x00) :> - (0x02, 0x1D, 0x00) :> - (0x02, 0x1E, 0x00) :> - (0x02, 0x1F, 0x00) :> - (0x02, 0x20, 0x00) :> - (0x02, 0x21, 0x00) :> - (0x02, 0x22, 0x00) :> - (0x02, 0x23, 0x00) :> - (0x02, 0x24, 0x00) :> - (0x02, 0x25, 0x00) :> - (0x02, 0x26, 0x00) :> - (0x02, 0x27, 0x00) :> - (0x02, 0x28, 0x00) :> - (0x02, 0x29, 0x00) :> - (0x02, 0x2A, 0x00) :> - (0x02, 0x2B, 0x00) :> - (0x02, 0x2C, 0x00) :> - (0x02, 0x2D, 0x00) :> - (0x02, 0x2E, 0x00) :> - (0x02, 0x2F, 0x00) :> - (0x02, 0x31, 0x0B) :> - (0x02, 0x32, 0x0B) :> - (0x02, 0x33, 0x0B) :> - (0x02, 0x34, 0x0B) :> - (0x02, 0x35, 0x00) :> - (0x02, 0x36, 0x00) :> - (0x02, 0x37, 0x00) :> - (0x02, 0x38, 0x80) :> - (0x02, 0x39, 0xCF) :> - (0x02, 0x3A, 0x00) :> - (0x02, 0x3B, 0x00) :> - (0x02, 0x3C, 0x00) :> - (0x02, 0x3D, 0x00) :> - (0x02, 0x3E, 0xC0) :> - (0x02, 0x47, 0x00) :> - (0x02, 0x48, 0x00) :> - (0x02, 0x49, 0x00) :> - (0x02, 0x4A, 0x00) :> - (0x02, 0x4B, 0x00) :> - (0x02, 0x4C, 0x00) :> - (0x02, 0x4D, 0x00) :> - (0x02, 0x4E, 0x00) :> - (0x02, 0x4F, 0x00) :> - (0x02, 0x50, 0x00) :> - (0x02, 0x51, 0x00) :> - (0x02, 0x52, 0x00) :> - (0x02, 0x53, 0x08) :> - (0x02, 0x54, 0x00) :> - (0x02, 0x55, 0x00) :> - (0x02, 0x56, 0x00) :> - (0x02, 0x57, 0x00) :> - (0x02, 0x58, 0x00) :> - (0x02, 0x59, 0x00) :> - (0x02, 0x5A, 0x00) :> - (0x02, 0x5B, 0x00) :> - (0x02, 0x5C, 0x02) :> - (0x02, 0x5D, 0x00) :> - (0x02, 0x5E, 0x00) :> - (0x02, 0x5F, 0x00) :> - (0x02, 0x60, 0x00) :> - (0x02, 0x61, 0x00) :> - (0x02, 0x62, 0x00) :> - (0x02, 0x63, 0x00) :> - (0x02, 0x64, 0x00) :> - (0x02, 0x65, 0x00) :> - (0x02, 0x66, 0x00) :> - (0x02, 0x67, 0x00) :> - (0x02, 0x68, 0x00) :> - (0x02, 0x69, 0x00) :> - (0x02, 0x6A, 0x00) :> - (0x02, 0x6B, 0x35) :> - (0x02, 0x6C, 0x33) :> - (0x02, 0x6D, 0x39) :> - (0x02, 0x6E, 0x35) :> - (0x02, 0x6F, 0x45) :> - (0x02, 0x70, 0x56) :> - (0x02, 0x71, 0x42) :> - (0x02, 0x72, 0x00) :> - (0x02, 0x8A, 0x00) :> - (0x02, 0x8B, 0x00) :> - (0x02, 0x8C, 0x00) :> - (0x02, 0x8D, 0x00) :> - (0x02, 0x8E, 0x00) :> - (0x02, 0x8F, 0x00) :> - (0x02, 0x90, 0x00) :> - (0x02, 0x91, 0x00) :> - (0x02, 0x92, 0x3F) :> - (0x02, 0x93, 0x2F) :> - (0x02, 0x94, 0x80) :> - (0x02, 0x96, 0x00) :> - (0x02, 0x97, 0x00) :> - (0x02, 0x99, 0x00) :> - (0x02, 0x9D, 0x00) :> - (0x02, 0x9E, 0x00) :> - (0x02, 0x9F, 0x00) :> - (0x02, 0xA9, 0x00) :> - (0x02, 0xAA, 0x00) :> - (0x02, 0xAB, 0x00) :> - (0x02, 0xB7, 0xFF) :> - (0x02, 0xBC, 0x00) :> - (0x03, 0x02, 0x00) :> - (0x03, 0x03, 0x00) :> - (0x03, 0x04, 0x00) :> - (0x03, 0x05, 0x60) :> - (0x03, 0x06, 0x0A) :> - (0x03, 0x07, 0x00) :> - (0x03, 0x08, 0x00) :> - (0x03, 0x09, 0x00) :> - (0x03, 0x0A, 0x00) :> - (0x03, 0x0B, 0xF0) :> - (0x03, 0x0C, 0x00) :> - (0x03, 0x0D, 0x00) :> - (0x03, 0x0E, 0x00) :> - (0x03, 0x0F, 0x00) :> - (0x03, 0x10, 0xC0) :> - (0x03, 0x11, 0x14) :> - (0x03, 0x12, 0x00) :> - (0x03, 0x13, 0x00) :> - (0x03, 0x14, 0x00) :> - (0x03, 0x15, 0x00) :> - (0x03, 0x16, 0x90) :> - (0x03, 0x17, 0x00) :> - (0x03, 0x18, 0x00) :> - (0x03, 0x19, 0x00) :> - (0x03, 0x1A, 0x00) :> - (0x03, 0x1B, 0x00) :> - (0x03, 0x1C, 0x00) :> - (0x03, 0x1D, 0x00) :> - (0x03, 0x1E, 0x00) :> - (0x03, 0x1F, 0x00) :> - (0x03, 0x20, 0x00) :> - (0x03, 0x21, 0x00) :> - (0x03, 0x22, 0x00) :> - (0x03, 0x23, 0x00) :> - (0x03, 0x24, 0x00) :> - (0x03, 0x25, 0x00) :> - (0x03, 0x26, 0x00) :> - (0x03, 0x27, 0x00) :> - (0x03, 0x28, 0x00) :> - (0x03, 0x29, 0x00) :> - (0x03, 0x2A, 0x00) :> - (0x03, 0x2B, 0x00) :> - (0x03, 0x2C, 0x00) :> - (0x03, 0x2D, 0x00) :> - (0x03, 0x2E, 0x00) :> - (0x03, 0x2F, 0x00) :> - (0x03, 0x30, 0x00) :> - (0x03, 0x31, 0x00) :> - (0x03, 0x32, 0x00) :> - (0x03, 0x33, 0x00) :> - (0x03, 0x34, 0x00) :> - (0x03, 0x35, 0x00) :> - (0x03, 0x36, 0x00) :> - (0x03, 0x37, 0x00) :> - (0x03, 0x38, 0x00) :> - (0x03, 0x39, 0x1C) :> - (0x03, 0x3B, 0x10) :> - (0x03, 0x3C, 0xAE) :> - (0x03, 0x3D, 0x00) :> - (0x03, 0x3E, 0x00) :> - (0x03, 0x3F, 0x00) :> - (0x03, 0x40, 0x00) :> - (0x03, 0x41, 0x74) :> - (0x03, 0x42, 0x83) :> - (0x03, 0x43, 0x4E) :> - (0x03, 0x44, 0x05) :> - (0x03, 0x45, 0x00) :> - (0x03, 0x46, 0x00) :> - (0x03, 0x47, 0x00) :> - (0x03, 0x48, 0x00) :> - (0x03, 0x49, 0x00) :> - (0x03, 0x4A, 0x00) :> - (0x03, 0x4B, 0x00) :> - (0x03, 0x4C, 0x00) :> - (0x03, 0x4D, 0x00) :> - (0x03, 0x4E, 0x00) :> - (0x03, 0x4F, 0x00) :> - (0x03, 0x50, 0x00) :> - (0x03, 0x51, 0x00) :> - (0x03, 0x52, 0x00) :> - (0x03, 0x53, 0x00) :> - (0x03, 0x54, 0x00) :> - (0x03, 0x55, 0x00) :> - (0x03, 0x56, 0x00) :> - (0x03, 0x57, 0x00) :> - (0x03, 0x58, 0x00) :> - (0x03, 0x59, 0x00) :> - (0x03, 0x5A, 0x00) :> - (0x03, 0x5B, 0x00) :> - (0x03, 0x5C, 0x00) :> - (0x03, 0x5D, 0x00) :> - (0x03, 0x5E, 0x00) :> - (0x03, 0x5F, 0x00) :> - (0x03, 0x60, 0x00) :> - (0x03, 0x61, 0x00) :> - (0x03, 0x62, 0x00) :> - (0x04, 0x87, 0x00) :> - (0x05, 0x08, 0x00) :> - (0x05, 0x09, 0x00) :> - (0x05, 0x0A, 0x00) :> - (0x05, 0x0B, 0x00) :> - (0x05, 0x0C, 0x00) :> - (0x05, 0x0D, 0x00) :> - (0x05, 0x0E, 0x00) :> - (0x05, 0x0F, 0x00) :> - (0x05, 0x10, 0x00) :> - (0x05, 0x11, 0x00) :> - (0x05, 0x12, 0x00) :> - (0x05, 0x13, 0x00) :> - (0x05, 0x15, 0x00) :> - (0x05, 0x16, 0x00) :> - (0x05, 0x17, 0x00) :> - (0x05, 0x18, 0x00) :> - (0x05, 0x19, 0x00) :> - (0x05, 0x1A, 0x00) :> - (0x05, 0x1B, 0x00) :> - (0x05, 0x1C, 0x00) :> - (0x05, 0x1D, 0x00) :> - (0x05, 0x1E, 0x00) :> - (0x05, 0x1F, 0x00) :> - (0x05, 0x21, 0x2B) :> - (0x05, 0x2A, 0x00) :> - (0x05, 0x2B, 0x01) :> - (0x05, 0x2C, 0x0F) :> - (0x05, 0x2D, 0x03) :> - (0x05, 0x2E, 0x00) :> - (0x05, 0x2F, 0x00) :> - (0x05, 0x31, 0x00) :> - (0x05, 0x32, 0x00) :> - (0x05, 0x33, 0x04) :> - (0x05, 0x34, 0x00) :> - (0x05, 0x35, 0x01) :> - (0x05, 0x36, 0x06) :> - (0x05, 0x37, 0x00) :> - (0x05, 0x38, 0x00) :> - (0x05, 0x39, 0x00) :> - (0x05, 0x3D, 0x0A) :> - (0x05, 0x3E, 0x06) :> - (0x05, 0x88, 0x00) :> - (0x05, 0x89, 0x0C) :> - (0x05, 0x8A, 0x00) :> - (0x05, 0x8B, 0x00) :> - (0x05, 0x8C, 0x00) :> - (0x05, 0x8D, 0x00) :> - (0x05, 0x9B, 0x18) :> - (0x05, 0x9C, 0x0C) :> - (0x05, 0x9D, 0x00) :> - (0x05, 0x9E, 0x00) :> - (0x05, 0x9F, 0x00) :> - (0x05, 0xA0, 0x00) :> - (0x05, 0xA1, 0x00) :> - (0x05, 0xA2, 0x00) :> - (0x05, 0xA4, 0x20) :> - (0x05, 0xA5, 0x00) :> - (0x05, 0xA6, 0x00) :> - (0x05, 0xAC, 0x00) :> - (0x05, 0xAD, 0x00) :> - (0x05, 0xAE, 0x00) :> - (0x05, 0xB1, 0x00) :> - (0x05, 0xB2, 0x00) :> - (0x08, 0x02, 0x35) :> - (0x08, 0x03, 0x05) :> - (0x08, 0x04, 0x01) :> - (0x08, 0x05, 0x00) :> - (0x08, 0x06, 0x00) :> - (0x08, 0x07, 0x00) :> - (0x08, 0x08, 0x00) :> - (0x08, 0x09, 0x00) :> - (0x08, 0x0A, 0x00) :> - (0x08, 0x0B, 0x00) :> - (0x08, 0x0C, 0x00) :> - (0x08, 0x0D, 0x00) :> - (0x08, 0x0E, 0x00) :> - (0x08, 0x0F, 0x00) :> - (0x08, 0x10, 0x00) :> - (0x08, 0x11, 0x00) :> - (0x08, 0x12, 0x00) :> - (0x08, 0x13, 0x00) :> - (0x08, 0x14, 0x00) :> - (0x08, 0x15, 0x00) :> - (0x08, 0x16, 0x00) :> - (0x08, 0x17, 0x00) :> - (0x08, 0x18, 0x00) :> - (0x08, 0x19, 0x00) :> - (0x08, 0x1A, 0x00) :> - (0x08, 0x1B, 0x00) :> - (0x08, 0x1C, 0x00) :> - (0x08, 0x1D, 0x00) :> - (0x08, 0x1E, 0x00) :> - (0x08, 0x1F, 0x00) :> - (0x08, 0x20, 0x00) :> - (0x08, 0x21, 0x00) :> - (0x08, 0x22, 0x00) :> - (0x08, 0x23, 0x00) :> - (0x08, 0x24, 0x00) :> - (0x08, 0x25, 0x00) :> - (0x08, 0x26, 0x00) :> - (0x08, 0x27, 0x00) :> - (0x08, 0x28, 0x00) :> - (0x08, 0x29, 0x00) :> - (0x08, 0x2A, 0x00) :> - (0x08, 0x2B, 0x00) :> - (0x08, 0x2C, 0x00) :> - (0x08, 0x2D, 0x00) :> - (0x08, 0x2E, 0x00) :> - (0x08, 0x2F, 0x00) :> - (0x08, 0x30, 0x00) :> - (0x08, 0x31, 0x00) :> - (0x08, 0x32, 0x00) :> - (0x08, 0x33, 0x00) :> - (0x08, 0x34, 0x00) :> - (0x08, 0x35, 0x00) :> - (0x08, 0x36, 0x00) :> - (0x08, 0x37, 0x00) :> - (0x08, 0x38, 0x00) :> - (0x08, 0x39, 0x00) :> - (0x08, 0x3A, 0x00) :> - (0x08, 0x3B, 0x00) :> - (0x08, 0x3C, 0x00) :> - (0x08, 0x3D, 0x00) :> - (0x08, 0x3E, 0x00) :> - (0x08, 0x3F, 0x00) :> - (0x08, 0x40, 0x00) :> - (0x08, 0x41, 0x00) :> - (0x08, 0x42, 0x00) :> - (0x08, 0x43, 0x00) :> - (0x08, 0x44, 0x00) :> - (0x08, 0x45, 0x00) :> - (0x08, 0x46, 0x00) :> - (0x08, 0x47, 0x00) :> - (0x08, 0x48, 0x00) :> - (0x08, 0x49, 0x00) :> - (0x08, 0x4A, 0x00) :> - (0x08, 0x4B, 0x00) :> - (0x08, 0x4C, 0x00) :> - (0x08, 0x4D, 0x00) :> - (0x08, 0x4E, 0x00) :> - (0x08, 0x4F, 0x00) :> - (0x08, 0x50, 0x00) :> - (0x08, 0x51, 0x00) :> - (0x08, 0x52, 0x00) :> - (0x08, 0x53, 0x00) :> - (0x08, 0x54, 0x00) :> - (0x08, 0x55, 0x00) :> - (0x08, 0x56, 0x00) :> - (0x08, 0x57, 0x00) :> - (0x08, 0x58, 0x00) :> - (0x08, 0x59, 0x00) :> - (0x08, 0x5A, 0x00) :> - (0x08, 0x5B, 0x00) :> - (0x08, 0x5C, 0x00) :> - (0x08, 0x5D, 0x00) :> - (0x08, 0x5E, 0x00) :> - (0x08, 0x5F, 0x00) :> - (0x08, 0x60, 0x00) :> - (0x08, 0x61, 0x00) :> - (0x09, 0x0E, 0x02) :> - (0x09, 0x43, 0x01) :> - (0x09, 0x49, 0x00) :> - (0x09, 0x4A, 0x00) :> - (0x09, 0x4E, 0x49) :> - (0x09, 0x4F, 0xF2) :> - (0x09, 0x5E, 0x00) :> - (0x0A, 0x02, 0x00) :> - (0x0A, 0x03, 0x03) :> - (0x0A, 0x04, 0x00) :> - (0x0A, 0x05, 0x03) :> - (0x0A, 0x14, 0x00) :> - (0x0A, 0x1A, 0x00) :> - (0x0A, 0x20, 0x00) :> - (0x0A, 0x26, 0x00) :> - (0x0A, 0x2C, 0x00) :> - (0x0A, 0x38, 0x00) :> - (0x0A, 0x39, 0x00) :> - (0x0A, 0x3A, 0x00) :> - (0x0A, 0x3C, 0x00) :> - (0x0A, 0x3D, 0x00) :> - (0x0A, 0x3E, 0x00) :> - (0x0A, 0x40, 0x00) :> - (0x0A, 0x41, 0x00) :> - (0x0A, 0x42, 0x00) :> - (0x0A, 0x44, 0x00) :> - (0x0A, 0x45, 0x00) :> - (0x0A, 0x46, 0x00) :> - (0x0A, 0x48, 0x00) :> - (0x0A, 0x49, 0x00) :> - (0x0A, 0x4A, 0x00) :> - (0x0A, 0x4C, 0x00) :> - (0x0A, 0x4D, 0x00) :> - (0x0A, 0x4E, 0x00) :> - (0x0A, 0x4F, 0x00) :> - (0x0A, 0x50, 0x00) :> - (0x0A, 0x51, 0x00) :> - (0x0A, 0x52, 0x00) :> - (0x0A, 0x53, 0x00) :> - (0x0A, 0x54, 0x00) :> - (0x0A, 0x55, 0x00) :> - (0x0A, 0x56, 0x00) :> - (0x0A, 0x57, 0x00) :> - (0x0A, 0x58, 0x00) :> - (0x0A, 0x59, 0x00) :> - (0x0A, 0x5A, 0x00) :> - (0x0A, 0x5B, 0x00) :> - (0x0A, 0x5C, 0x00) :> - (0x0A, 0x5D, 0x00) :> - (0x0A, 0x5E, 0x00) :> - (0x0A, 0x5F, 0x00) :> - (0x0B, 0x44, 0x0F) :> - (0x0B, 0x46, 0x00) :> - (0x0B, 0x47, 0x0F) :> - (0x0B, 0x48, 0x0F) :> - (0x0B, 0x4A, 0x1C) :> - (0x0B, 0x57, 0x0E) :> - (0x0B, 0x58, 0x01) :> - (0x0C, 0x02, 0x03) :> - (0x0C, 0x03, 0x00) :> - (0x0C, 0x07, 0x00) :> - (0x0C, 0x08, 0x00) :> Nil - + (0x00, 0x06, 0x00) + :> (0x00, 0x07, 0x00) + :> (0x00, 0x08, 0x00) + :> (0x00, 0x0B, 0x68) + :> (0x00, 0x16, 0x02) + :> (0x00, 0x17, 0xDC) + :> (0x00, 0x18, 0xFF) + :> (0x00, 0x19, 0xFF) + :> (0x00, 0x1A, 0xFF) + :> (0x00, 0x2B, 0x02) + :> (0x00, 0x2C, 0x00) + :> (0x00, 0x2D, 0x00) + :> (0x00, 0x2E, 0x00) + :> (0x00, 0x2F, 0x00) + :> (0x00, 0x30, 0x00) + :> (0x00, 0x31, 0x00) + :> (0x00, 0x32, 0x00) + :> (0x00, 0x33, 0x00) + :> (0x00, 0x34, 0x00) + :> (0x00, 0x35, 0x00) + :> (0x00, 0x36, 0x00) + :> (0x00, 0x37, 0x00) + :> (0x00, 0x38, 0x00) + :> (0x00, 0x39, 0x00) + :> (0x00, 0x3A, 0x00) + :> (0x00, 0x3B, 0x00) + :> (0x00, 0x3C, 0x00) + :> (0x00, 0x3D, 0x00) + :> (0x00, 0x3E, 0x00) + :> (0x00, 0x3F, 0x00) + :> (0x00, 0x40, 0x04) + :> (0x00, 0x41, 0x00) + :> (0x00, 0x42, 0x00) + :> (0x00, 0x43, 0x00) + :> (0x00, 0x44, 0x00) + :> (0x00, 0x45, 0x0C) + :> (0x00, 0x46, 0x00) + :> (0x00, 0x47, 0x00) + :> (0x00, 0x48, 0x00) + :> (0x00, 0x49, 0x00) + :> (0x00, 0x4A, 0x00) + :> (0x00, 0x4B, 0x00) + :> (0x00, 0x4C, 0x00) + :> (0x00, 0x4D, 0x00) + :> (0x00, 0x4E, 0x00) + :> (0x00, 0x4F, 0x00) + :> (0x00, 0x50, 0x0F) + :> (0x00, 0x51, 0x00) + :> (0x00, 0x52, 0x00) + :> (0x00, 0x53, 0x00) + :> (0x00, 0x54, 0x00) + :> (0x00, 0x55, 0x00) + :> (0x00, 0x56, 0x00) + :> (0x00, 0x57, 0x00) + :> (0x00, 0x58, 0x00) + :> (0x00, 0x59, 0x00) + :> (0x00, 0x5A, 0x00) + :> (0x00, 0x5B, 0x00) + :> (0x00, 0x5C, 0x00) + :> (0x00, 0x5D, 0x00) + :> (0x00, 0x5E, 0x00) + :> (0x00, 0x5F, 0x00) + :> (0x00, 0x60, 0x00) + :> (0x00, 0x61, 0x00) + :> (0x00, 0x62, 0x00) + :> (0x00, 0x63, 0x00) + :> (0x00, 0x64, 0x00) + :> (0x00, 0x65, 0x00) + :> (0x00, 0x66, 0x00) + :> (0x00, 0x67, 0x00) + :> (0x00, 0x68, 0x00) + :> (0x00, 0x69, 0x00) + :> (0x00, 0x92, 0x00) + :> (0x00, 0x93, 0x00) + :> (0x00, 0x95, 0x00) + :> (0x00, 0x96, 0x00) + :> (0x00, 0x98, 0x00) + :> (0x00, 0x9A, 0x00) + :> (0x00, 0x9B, 0x00) + :> (0x00, 0x9D, 0x00) + :> (0x00, 0x9E, 0x00) + :> (0x00, 0xA0, 0x00) + :> (0x00, 0xA2, 0x00) + :> (0x00, 0xA9, 0x00) + :> (0x00, 0xAA, 0x00) + :> (0x00, 0xAB, 0x00) + :> (0x00, 0xAC, 0x00) + :> (0x00, 0xE5, 0x01) + :> (0x00, 0xEA, 0x00) + :> (0x00, 0xEB, 0x00) + :> (0x00, 0xEC, 0x00) + :> (0x00, 0xED, 0x00) + :> (0x01, 0x02, 0x01) + :> (0x01, 0x03, 0x01) + :> (0x01, 0x04, 0x09) + :> (0x01, 0x05, 0x3B) + :> (0x01, 0x06, 0x28) + :> (0x01, 0x08, 0x01) + :> (0x01, 0x09, 0x09) + :> (0x01, 0x0A, 0x3B) + :> (0x01, 0x0B, 0x28) + :> (0x01, 0x0D, 0x01) + :> (0x01, 0x0E, 0x09) + :> (0x01, 0x0F, 0x3B) + :> (0x01, 0x10, 0x28) + :> (0x01, 0x12, 0x01) + :> (0x01, 0x13, 0x09) + :> (0x01, 0x14, 0x3B) + :> (0x01, 0x15, 0x28) + :> (0x01, 0x17, 0x02) + :> (0x01, 0x18, 0xCC) + :> (0x01, 0x19, 0x00) + :> (0x01, 0x1A, 0x19) + :> (0x01, 0x1C, 0x01) + :> (0x01, 0x1D, 0x09) + :> (0x01, 0x1E, 0x3B) + :> (0x01, 0x1F, 0x28) + :> (0x01, 0x21, 0x01) + :> (0x01, 0x22, 0x09) + :> (0x01, 0x23, 0x3B) + :> (0x01, 0x24, 0x28) + :> (0x01, 0x26, 0x02) + :> (0x01, 0x27, 0x09) + :> (0x01, 0x28, 0x3E) + :> (0x01, 0x29, 0x18) + :> (0x01, 0x2B, 0x01) + :> (0x01, 0x2C, 0x09) + :> (0x01, 0x2D, 0x3B) + :> (0x01, 0x2E, 0x28) + :> (0x01, 0x30, 0x01) + :> (0x01, 0x31, 0x09) + :> (0x01, 0x32, 0x3B) + :> (0x01, 0x33, 0x28) + :> (0x01, 0x35, 0x01) + :> (0x01, 0x36, 0x09) + :> (0x01, 0x37, 0x3B) + :> (0x01, 0x38, 0x28) + :> (0x01, 0x3A, 0x01) + :> (0x01, 0x3B, 0x09) + :> (0x01, 0x3C, 0x3E) + :> (0x01, 0x3D, 0x18) + :> (0x01, 0x3F, 0x00) + :> (0x01, 0x40, 0x00) + :> (0x01, 0x41, 0x40) + :> (0x01, 0x42, 0xFF) + :> (0x02, 0x06, 0x00) + :> (0x02, 0x08, 0x00) + :> (0x02, 0x09, 0x00) + :> (0x02, 0x0A, 0x00) + :> (0x02, 0x0B, 0x00) + :> (0x02, 0x0C, 0x00) + :> (0x02, 0x0D, 0x00) + :> (0x02, 0x0E, 0x00) + :> (0x02, 0x0F, 0x00) + :> (0x02, 0x10, 0x00) + :> (0x02, 0x11, 0x00) + :> (0x02, 0x12, 0x00) + :> (0x02, 0x13, 0x00) + :> (0x02, 0x14, 0x00) + :> (0x02, 0x15, 0x00) + :> (0x02, 0x16, 0x00) + :> (0x02, 0x17, 0x00) + :> (0x02, 0x18, 0x00) + :> (0x02, 0x19, 0x00) + :> (0x02, 0x1A, 0x00) + :> (0x02, 0x1B, 0x00) + :> (0x02, 0x1C, 0x00) + :> (0x02, 0x1D, 0x00) + :> (0x02, 0x1E, 0x00) + :> (0x02, 0x1F, 0x00) + :> (0x02, 0x20, 0x00) + :> (0x02, 0x21, 0x00) + :> (0x02, 0x22, 0x00) + :> (0x02, 0x23, 0x00) + :> (0x02, 0x24, 0x00) + :> (0x02, 0x25, 0x00) + :> (0x02, 0x26, 0x00) + :> (0x02, 0x27, 0x00) + :> (0x02, 0x28, 0x00) + :> (0x02, 0x29, 0x00) + :> (0x02, 0x2A, 0x00) + :> (0x02, 0x2B, 0x00) + :> (0x02, 0x2C, 0x00) + :> (0x02, 0x2D, 0x00) + :> (0x02, 0x2E, 0x00) + :> (0x02, 0x2F, 0x00) + :> (0x02, 0x31, 0x0B) + :> (0x02, 0x32, 0x0B) + :> (0x02, 0x33, 0x0B) + :> (0x02, 0x34, 0x0B) + :> (0x02, 0x35, 0x00) + :> (0x02, 0x36, 0x00) + :> (0x02, 0x37, 0x00) + :> (0x02, 0x38, 0x80) + :> (0x02, 0x39, 0xCF) + :> (0x02, 0x3A, 0x00) + :> (0x02, 0x3B, 0x00) + :> (0x02, 0x3C, 0x00) + :> (0x02, 0x3D, 0x00) + :> (0x02, 0x3E, 0xC0) + :> (0x02, 0x47, 0x00) + :> (0x02, 0x48, 0x00) + :> (0x02, 0x49, 0x00) + :> (0x02, 0x4A, 0x00) + :> (0x02, 0x4B, 0x00) + :> (0x02, 0x4C, 0x00) + :> (0x02, 0x4D, 0x00) + :> (0x02, 0x4E, 0x00) + :> (0x02, 0x4F, 0x00) + :> (0x02, 0x50, 0x00) + :> (0x02, 0x51, 0x00) + :> (0x02, 0x52, 0x00) + :> (0x02, 0x53, 0x08) + :> (0x02, 0x54, 0x00) + :> (0x02, 0x55, 0x00) + :> (0x02, 0x56, 0x00) + :> (0x02, 0x57, 0x00) + :> (0x02, 0x58, 0x00) + :> (0x02, 0x59, 0x00) + :> (0x02, 0x5A, 0x00) + :> (0x02, 0x5B, 0x00) + :> (0x02, 0x5C, 0x02) + :> (0x02, 0x5D, 0x00) + :> (0x02, 0x5E, 0x00) + :> (0x02, 0x5F, 0x00) + :> (0x02, 0x60, 0x00) + :> (0x02, 0x61, 0x00) + :> (0x02, 0x62, 0x00) + :> (0x02, 0x63, 0x00) + :> (0x02, 0x64, 0x00) + :> (0x02, 0x65, 0x00) + :> (0x02, 0x66, 0x00) + :> (0x02, 0x67, 0x00) + :> (0x02, 0x68, 0x00) + :> (0x02, 0x69, 0x00) + :> (0x02, 0x6A, 0x00) + :> (0x02, 0x6B, 0x35) + :> (0x02, 0x6C, 0x33) + :> (0x02, 0x6D, 0x39) + :> (0x02, 0x6E, 0x35) + :> (0x02, 0x6F, 0x45) + :> (0x02, 0x70, 0x56) + :> (0x02, 0x71, 0x42) + :> (0x02, 0x72, 0x00) + :> (0x02, 0x8A, 0x00) + :> (0x02, 0x8B, 0x00) + :> (0x02, 0x8C, 0x00) + :> (0x02, 0x8D, 0x00) + :> (0x02, 0x8E, 0x00) + :> (0x02, 0x8F, 0x00) + :> (0x02, 0x90, 0x00) + :> (0x02, 0x91, 0x00) + :> (0x02, 0x92, 0x3F) + :> (0x02, 0x93, 0x2F) + :> (0x02, 0x94, 0x80) + :> (0x02, 0x96, 0x00) + :> (0x02, 0x97, 0x00) + :> (0x02, 0x99, 0x00) + :> (0x02, 0x9D, 0x00) + :> (0x02, 0x9E, 0x00) + :> (0x02, 0x9F, 0x00) + :> (0x02, 0xA9, 0x00) + :> (0x02, 0xAA, 0x00) + :> (0x02, 0xAB, 0x00) + :> (0x02, 0xB7, 0xFF) + :> (0x02, 0xBC, 0x00) + :> (0x03, 0x02, 0x00) + :> (0x03, 0x03, 0x00) + :> (0x03, 0x04, 0x00) + :> (0x03, 0x05, 0x60) + :> (0x03, 0x06, 0x0A) + :> (0x03, 0x07, 0x00) + :> (0x03, 0x08, 0x00) + :> (0x03, 0x09, 0x00) + :> (0x03, 0x0A, 0x00) + :> (0x03, 0x0B, 0xF0) + :> (0x03, 0x0C, 0x00) + :> (0x03, 0x0D, 0x00) + :> (0x03, 0x0E, 0x00) + :> (0x03, 0x0F, 0x00) + :> (0x03, 0x10, 0xC0) + :> (0x03, 0x11, 0x14) + :> (0x03, 0x12, 0x00) + :> (0x03, 0x13, 0x00) + :> (0x03, 0x14, 0x00) + :> (0x03, 0x15, 0x00) + :> (0x03, 0x16, 0x90) + :> (0x03, 0x17, 0x00) + :> (0x03, 0x18, 0x00) + :> (0x03, 0x19, 0x00) + :> (0x03, 0x1A, 0x00) + :> (0x03, 0x1B, 0x00) + :> (0x03, 0x1C, 0x00) + :> (0x03, 0x1D, 0x00) + :> (0x03, 0x1E, 0x00) + :> (0x03, 0x1F, 0x00) + :> (0x03, 0x20, 0x00) + :> (0x03, 0x21, 0x00) + :> (0x03, 0x22, 0x00) + :> (0x03, 0x23, 0x00) + :> (0x03, 0x24, 0x00) + :> (0x03, 0x25, 0x00) + :> (0x03, 0x26, 0x00) + :> (0x03, 0x27, 0x00) + :> (0x03, 0x28, 0x00) + :> (0x03, 0x29, 0x00) + :> (0x03, 0x2A, 0x00) + :> (0x03, 0x2B, 0x00) + :> (0x03, 0x2C, 0x00) + :> (0x03, 0x2D, 0x00) + :> (0x03, 0x2E, 0x00) + :> (0x03, 0x2F, 0x00) + :> (0x03, 0x30, 0x00) + :> (0x03, 0x31, 0x00) + :> (0x03, 0x32, 0x00) + :> (0x03, 0x33, 0x00) + :> (0x03, 0x34, 0x00) + :> (0x03, 0x35, 0x00) + :> (0x03, 0x36, 0x00) + :> (0x03, 0x37, 0x00) + :> (0x03, 0x38, 0x00) + :> (0x03, 0x39, 0x1C) + :> (0x03, 0x3B, 0x10) + :> (0x03, 0x3C, 0xAE) + :> (0x03, 0x3D, 0x00) + :> (0x03, 0x3E, 0x00) + :> (0x03, 0x3F, 0x00) + :> (0x03, 0x40, 0x00) + :> (0x03, 0x41, 0x74) + :> (0x03, 0x42, 0x83) + :> (0x03, 0x43, 0x4E) + :> (0x03, 0x44, 0x05) + :> (0x03, 0x45, 0x00) + :> (0x03, 0x46, 0x00) + :> (0x03, 0x47, 0x00) + :> (0x03, 0x48, 0x00) + :> (0x03, 0x49, 0x00) + :> (0x03, 0x4A, 0x00) + :> (0x03, 0x4B, 0x00) + :> (0x03, 0x4C, 0x00) + :> (0x03, 0x4D, 0x00) + :> (0x03, 0x4E, 0x00) + :> (0x03, 0x4F, 0x00) + :> (0x03, 0x50, 0x00) + :> (0x03, 0x51, 0x00) + :> (0x03, 0x52, 0x00) + :> (0x03, 0x53, 0x00) + :> (0x03, 0x54, 0x00) + :> (0x03, 0x55, 0x00) + :> (0x03, 0x56, 0x00) + :> (0x03, 0x57, 0x00) + :> (0x03, 0x58, 0x00) + :> (0x03, 0x59, 0x00) + :> (0x03, 0x5A, 0x00) + :> (0x03, 0x5B, 0x00) + :> (0x03, 0x5C, 0x00) + :> (0x03, 0x5D, 0x00) + :> (0x03, 0x5E, 0x00) + :> (0x03, 0x5F, 0x00) + :> (0x03, 0x60, 0x00) + :> (0x03, 0x61, 0x00) + :> (0x03, 0x62, 0x00) + :> (0x04, 0x87, 0x00) + :> (0x05, 0x08, 0x00) + :> (0x05, 0x09, 0x00) + :> (0x05, 0x0A, 0x00) + :> (0x05, 0x0B, 0x00) + :> (0x05, 0x0C, 0x00) + :> (0x05, 0x0D, 0x00) + :> (0x05, 0x0E, 0x00) + :> (0x05, 0x0F, 0x00) + :> (0x05, 0x10, 0x00) + :> (0x05, 0x11, 0x00) + :> (0x05, 0x12, 0x00) + :> (0x05, 0x13, 0x00) + :> (0x05, 0x15, 0x00) + :> (0x05, 0x16, 0x00) + :> (0x05, 0x17, 0x00) + :> (0x05, 0x18, 0x00) + :> (0x05, 0x19, 0x00) + :> (0x05, 0x1A, 0x00) + :> (0x05, 0x1B, 0x00) + :> (0x05, 0x1C, 0x00) + :> (0x05, 0x1D, 0x00) + :> (0x05, 0x1E, 0x00) + :> (0x05, 0x1F, 0x00) + :> (0x05, 0x21, 0x2B) + :> (0x05, 0x2A, 0x00) + :> (0x05, 0x2B, 0x01) + :> (0x05, 0x2C, 0x0F) + :> (0x05, 0x2D, 0x03) + :> (0x05, 0x2E, 0x00) + :> (0x05, 0x2F, 0x00) + :> (0x05, 0x31, 0x00) + :> (0x05, 0x32, 0x00) + :> (0x05, 0x33, 0x04) + :> (0x05, 0x34, 0x00) + :> (0x05, 0x35, 0x01) + :> (0x05, 0x36, 0x06) + :> (0x05, 0x37, 0x00) + :> (0x05, 0x38, 0x00) + :> (0x05, 0x39, 0x00) + :> (0x05, 0x3D, 0x0A) + :> (0x05, 0x3E, 0x06) + :> (0x05, 0x88, 0x00) + :> (0x05, 0x89, 0x0C) + :> (0x05, 0x8A, 0x00) + :> (0x05, 0x8B, 0x00) + :> (0x05, 0x8C, 0x00) + :> (0x05, 0x8D, 0x00) + :> (0x05, 0x9B, 0x18) + :> (0x05, 0x9C, 0x0C) + :> (0x05, 0x9D, 0x00) + :> (0x05, 0x9E, 0x00) + :> (0x05, 0x9F, 0x00) + :> (0x05, 0xA0, 0x00) + :> (0x05, 0xA1, 0x00) + :> (0x05, 0xA2, 0x00) + :> (0x05, 0xA4, 0x20) + :> (0x05, 0xA5, 0x00) + :> (0x05, 0xA6, 0x00) + :> (0x05, 0xAC, 0x00) + :> (0x05, 0xAD, 0x00) + :> (0x05, 0xAE, 0x00) + :> (0x05, 0xB1, 0x00) + :> (0x05, 0xB2, 0x00) + :> (0x08, 0x02, 0x35) + :> (0x08, 0x03, 0x05) + :> (0x08, 0x04, 0x01) + :> (0x08, 0x05, 0x00) + :> (0x08, 0x06, 0x00) + :> (0x08, 0x07, 0x00) + :> (0x08, 0x08, 0x00) + :> (0x08, 0x09, 0x00) + :> (0x08, 0x0A, 0x00) + :> (0x08, 0x0B, 0x00) + :> (0x08, 0x0C, 0x00) + :> (0x08, 0x0D, 0x00) + :> (0x08, 0x0E, 0x00) + :> (0x08, 0x0F, 0x00) + :> (0x08, 0x10, 0x00) + :> (0x08, 0x11, 0x00) + :> (0x08, 0x12, 0x00) + :> (0x08, 0x13, 0x00) + :> (0x08, 0x14, 0x00) + :> (0x08, 0x15, 0x00) + :> (0x08, 0x16, 0x00) + :> (0x08, 0x17, 0x00) + :> (0x08, 0x18, 0x00) + :> (0x08, 0x19, 0x00) + :> (0x08, 0x1A, 0x00) + :> (0x08, 0x1B, 0x00) + :> (0x08, 0x1C, 0x00) + :> (0x08, 0x1D, 0x00) + :> (0x08, 0x1E, 0x00) + :> (0x08, 0x1F, 0x00) + :> (0x08, 0x20, 0x00) + :> (0x08, 0x21, 0x00) + :> (0x08, 0x22, 0x00) + :> (0x08, 0x23, 0x00) + :> (0x08, 0x24, 0x00) + :> (0x08, 0x25, 0x00) + :> (0x08, 0x26, 0x00) + :> (0x08, 0x27, 0x00) + :> (0x08, 0x28, 0x00) + :> (0x08, 0x29, 0x00) + :> (0x08, 0x2A, 0x00) + :> (0x08, 0x2B, 0x00) + :> (0x08, 0x2C, 0x00) + :> (0x08, 0x2D, 0x00) + :> (0x08, 0x2E, 0x00) + :> (0x08, 0x2F, 0x00) + :> (0x08, 0x30, 0x00) + :> (0x08, 0x31, 0x00) + :> (0x08, 0x32, 0x00) + :> (0x08, 0x33, 0x00) + :> (0x08, 0x34, 0x00) + :> (0x08, 0x35, 0x00) + :> (0x08, 0x36, 0x00) + :> (0x08, 0x37, 0x00) + :> (0x08, 0x38, 0x00) + :> (0x08, 0x39, 0x00) + :> (0x08, 0x3A, 0x00) + :> (0x08, 0x3B, 0x00) + :> (0x08, 0x3C, 0x00) + :> (0x08, 0x3D, 0x00) + :> (0x08, 0x3E, 0x00) + :> (0x08, 0x3F, 0x00) + :> (0x08, 0x40, 0x00) + :> (0x08, 0x41, 0x00) + :> (0x08, 0x42, 0x00) + :> (0x08, 0x43, 0x00) + :> (0x08, 0x44, 0x00) + :> (0x08, 0x45, 0x00) + :> (0x08, 0x46, 0x00) + :> (0x08, 0x47, 0x00) + :> (0x08, 0x48, 0x00) + :> (0x08, 0x49, 0x00) + :> (0x08, 0x4A, 0x00) + :> (0x08, 0x4B, 0x00) + :> (0x08, 0x4C, 0x00) + :> (0x08, 0x4D, 0x00) + :> (0x08, 0x4E, 0x00) + :> (0x08, 0x4F, 0x00) + :> (0x08, 0x50, 0x00) + :> (0x08, 0x51, 0x00) + :> (0x08, 0x52, 0x00) + :> (0x08, 0x53, 0x00) + :> (0x08, 0x54, 0x00) + :> (0x08, 0x55, 0x00) + :> (0x08, 0x56, 0x00) + :> (0x08, 0x57, 0x00) + :> (0x08, 0x58, 0x00) + :> (0x08, 0x59, 0x00) + :> (0x08, 0x5A, 0x00) + :> (0x08, 0x5B, 0x00) + :> (0x08, 0x5C, 0x00) + :> (0x08, 0x5D, 0x00) + :> (0x08, 0x5E, 0x00) + :> (0x08, 0x5F, 0x00) + :> (0x08, 0x60, 0x00) + :> (0x08, 0x61, 0x00) + :> (0x09, 0x0E, 0x02) + :> (0x09, 0x43, 0x01) + :> (0x09, 0x49, 0x00) + :> (0x09, 0x4A, 0x00) + :> (0x09, 0x4E, 0x49) + :> (0x09, 0x4F, 0xF2) + :> (0x09, 0x5E, 0x00) + :> (0x0A, 0x02, 0x00) + :> (0x0A, 0x03, 0x03) + :> (0x0A, 0x04, 0x00) + :> (0x0A, 0x05, 0x03) + :> (0x0A, 0x14, 0x00) + :> (0x0A, 0x1A, 0x00) + :> (0x0A, 0x20, 0x00) + :> (0x0A, 0x26, 0x00) + :> (0x0A, 0x2C, 0x00) + :> (0x0A, 0x38, 0x00) + :> (0x0A, 0x39, 0x00) + :> (0x0A, 0x3A, 0x00) + :> (0x0A, 0x3C, 0x00) + :> (0x0A, 0x3D, 0x00) + :> (0x0A, 0x3E, 0x00) + :> (0x0A, 0x40, 0x00) + :> (0x0A, 0x41, 0x00) + :> (0x0A, 0x42, 0x00) + :> (0x0A, 0x44, 0x00) + :> (0x0A, 0x45, 0x00) + :> (0x0A, 0x46, 0x00) + :> (0x0A, 0x48, 0x00) + :> (0x0A, 0x49, 0x00) + :> (0x0A, 0x4A, 0x00) + :> (0x0A, 0x4C, 0x00) + :> (0x0A, 0x4D, 0x00) + :> (0x0A, 0x4E, 0x00) + :> (0x0A, 0x4F, 0x00) + :> (0x0A, 0x50, 0x00) + :> (0x0A, 0x51, 0x00) + :> (0x0A, 0x52, 0x00) + :> (0x0A, 0x53, 0x00) + :> (0x0A, 0x54, 0x00) + :> (0x0A, 0x55, 0x00) + :> (0x0A, 0x56, 0x00) + :> (0x0A, 0x57, 0x00) + :> (0x0A, 0x58, 0x00) + :> (0x0A, 0x59, 0x00) + :> (0x0A, 0x5A, 0x00) + :> (0x0A, 0x5B, 0x00) + :> (0x0A, 0x5C, 0x00) + :> (0x0A, 0x5D, 0x00) + :> (0x0A, 0x5E, 0x00) + :> (0x0A, 0x5F, 0x00) + :> (0x0B, 0x44, 0x0F) + :> (0x0B, 0x46, 0x00) + :> (0x0B, 0x47, 0x0F) + :> (0x0B, 0x48, 0x0F) + :> (0x0B, 0x4A, 0x1C) + :> (0x0B, 0x57, 0x0E) + :> (0x0B, 0x58, 0x01) + :> (0x0C, 0x02, 0x03) + :> (0x0C, 0x03, 0x00) + :> (0x0C, 0x07, 0x00) + :> (0x0C, 0x08, 0x00) + :> Nil -{-| Configuration for Si5395J with +{- | Configuration for Si5395J with out0a: 200MHz LVDS 1.8V connected to GTH SMA clk input (clk0 on quad 226) out0: 200MHz LVDS 1.8V connected to User SMA clk input on node 7 only out9: 20MHZ LVDS 1.8V out9a: 200MHz LVDS 1.8V all of them doing 10ppb steps on Finc/Fdec -} -testConfig6_200_on_0a_1ppb_and_0 :: Si5395RegisterMap +testConfig6_200_on_0a_1ppb_and_0 :: Si5395RegisterMap testConfig6_200_on_0a_1ppb_and_0 = Si539xRegisterMap{..} where configPreamble = (0x0B, 0x24, 0xC0) :> (0x0B, 0x25, 0x00) :> (0x05, 0x40, 0x01) :> Nil - configPostamble = (0x05, 0x14, 0x01) :> (0x00, 0x1C, 0x01) :> (0x05, 0x40, 0x00) :> (0x0B, 0x24, 0xC3) :> (0x0B, 0x25, 0x02) :> Nil + configPostamble = + (0x05, 0x14, 0x01) + :> (0x00, 0x1C, 0x01) + :> (0x05, 0x40, 0x00) + :> (0x0B, 0x24, 0xC3) + :> (0x0B, 0x25, 0x02) + :> Nil config = - (0x00, 0x06, 0x00) :> - (0x00, 0x07, 0x00) :> - (0x00, 0x08, 0x00) :> - (0x00, 0x0B, 0x68) :> - (0x00, 0x16, 0x02) :> - (0x00, 0x17, 0xDC) :> - (0x00, 0x18, 0xFF) :> - (0x00, 0x19, 0xFF) :> - (0x00, 0x1A, 0xFF) :> - (0x00, 0x2B, 0x02) :> - (0x00, 0x2C, 0x00) :> - (0x00, 0x2D, 0x00) :> - (0x00, 0x2E, 0x00) :> - (0x00, 0x2F, 0x00) :> - (0x00, 0x30, 0x00) :> - (0x00, 0x31, 0x00) :> - (0x00, 0x32, 0x00) :> - (0x00, 0x33, 0x00) :> - (0x00, 0x34, 0x00) :> - (0x00, 0x35, 0x00) :> - (0x00, 0x36, 0x00) :> - (0x00, 0x37, 0x00) :> - (0x00, 0x38, 0x00) :> - (0x00, 0x39, 0x00) :> - (0x00, 0x3A, 0x00) :> - (0x00, 0x3B, 0x00) :> - (0x00, 0x3C, 0x00) :> - (0x00, 0x3D, 0x00) :> - (0x00, 0x3E, 0x00) :> - (0x00, 0x3F, 0x00) :> - (0x00, 0x40, 0x04) :> - (0x00, 0x41, 0x00) :> - (0x00, 0x42, 0x00) :> - (0x00, 0x43, 0x00) :> - (0x00, 0x44, 0x00) :> - (0x00, 0x45, 0x0C) :> - (0x00, 0x46, 0x00) :> - (0x00, 0x47, 0x00) :> - (0x00, 0x48, 0x00) :> - (0x00, 0x49, 0x00) :> - (0x00, 0x4A, 0x00) :> - (0x00, 0x4B, 0x00) :> - (0x00, 0x4C, 0x00) :> - (0x00, 0x4D, 0x00) :> - (0x00, 0x4E, 0x00) :> - (0x00, 0x4F, 0x00) :> - (0x00, 0x50, 0x0F) :> - (0x00, 0x51, 0x00) :> - (0x00, 0x52, 0x00) :> - (0x00, 0x53, 0x00) :> - (0x00, 0x54, 0x00) :> - (0x00, 0x55, 0x00) :> - (0x00, 0x56, 0x00) :> - (0x00, 0x57, 0x00) :> - (0x00, 0x58, 0x00) :> - (0x00, 0x59, 0x00) :> - (0x00, 0x5A, 0x00) :> - (0x00, 0x5B, 0x00) :> - (0x00, 0x5C, 0x00) :> - (0x00, 0x5D, 0x00) :> - (0x00, 0x5E, 0x00) :> - (0x00, 0x5F, 0x00) :> - (0x00, 0x60, 0x00) :> - (0x00, 0x61, 0x00) :> - (0x00, 0x62, 0x00) :> - (0x00, 0x63, 0x00) :> - (0x00, 0x64, 0x00) :> - (0x00, 0x65, 0x00) :> - (0x00, 0x66, 0x00) :> - (0x00, 0x67, 0x00) :> - (0x00, 0x68, 0x00) :> - (0x00, 0x69, 0x00) :> - (0x00, 0x92, 0x00) :> - (0x00, 0x93, 0x00) :> - (0x00, 0x95, 0x00) :> - (0x00, 0x96, 0x00) :> - (0x00, 0x98, 0x00) :> - (0x00, 0x9A, 0x00) :> - (0x00, 0x9B, 0x00) :> - (0x00, 0x9D, 0x00) :> - (0x00, 0x9E, 0x00) :> - (0x00, 0xA0, 0x00) :> - (0x00, 0xA2, 0x00) :> - (0x00, 0xA9, 0x00) :> - (0x00, 0xAA, 0x00) :> - (0x00, 0xAB, 0x00) :> - (0x00, 0xAC, 0x00) :> - (0x00, 0xE5, 0x01) :> - (0x00, 0xEA, 0x00) :> - (0x00, 0xEB, 0x00) :> - (0x00, 0xEC, 0x00) :> - (0x00, 0xED, 0x00) :> - (0x01, 0x02, 0x01) :> - (0x01, 0x03, 0x06) :> - (0x01, 0x04, 0x09) :> - (0x01, 0x05, 0x3E) :> - (0x01, 0x06, 0x18) :> - (0x01, 0x08, 0x06) :> - (0x01, 0x09, 0x09) :> - (0x01, 0x0A, 0x3E) :> - (0x01, 0x0B, 0x18) :> - (0x01, 0x0D, 0x01) :> - (0x01, 0x0E, 0x09) :> - (0x01, 0x0F, 0x3B) :> - (0x01, 0x10, 0x28) :> - (0x01, 0x12, 0x01) :> - (0x01, 0x13, 0x09) :> - (0x01, 0x14, 0x3B) :> - (0x01, 0x15, 0x28) :> - (0x01, 0x17, 0x01) :> - (0x01, 0x18, 0x09) :> - (0x01, 0x19, 0x3B) :> - (0x01, 0x1A, 0x28) :> - (0x01, 0x1C, 0x01) :> - (0x01, 0x1D, 0x09) :> - (0x01, 0x1E, 0x3B) :> - (0x01, 0x1F, 0x28) :> - (0x01, 0x21, 0x01) :> - (0x01, 0x22, 0x09) :> - (0x01, 0x23, 0x3B) :> - (0x01, 0x24, 0x28) :> - (0x01, 0x26, 0x01) :> - (0x01, 0x27, 0x09) :> - (0x01, 0x28, 0x3B) :> - (0x01, 0x29, 0x28) :> - (0x01, 0x2B, 0x01) :> - (0x01, 0x2C, 0x09) :> - (0x01, 0x2D, 0x3B) :> - (0x01, 0x2E, 0x28) :> - (0x01, 0x30, 0x01) :> - (0x01, 0x31, 0x09) :> - (0x01, 0x32, 0x3B) :> - (0x01, 0x33, 0x28) :> - (0x01, 0x35, 0x02) :> - (0x01, 0x36, 0x09) :> - (0x01, 0x37, 0x3E) :> - (0x01, 0x38, 0x19) :> - (0x01, 0x3A, 0x06) :> - (0x01, 0x3B, 0x09) :> - (0x01, 0x3C, 0x3E) :> - (0x01, 0x3D, 0x19) :> - (0x01, 0x3F, 0x00) :> - (0x01, 0x40, 0x00) :> - (0x01, 0x41, 0x40) :> - (0x01, 0x42, 0xFF) :> - (0x02, 0x06, 0x00) :> - (0x02, 0x08, 0x00) :> - (0x02, 0x09, 0x00) :> - (0x02, 0x0A, 0x00) :> - (0x02, 0x0B, 0x00) :> - (0x02, 0x0C, 0x00) :> - (0x02, 0x0D, 0x00) :> - (0x02, 0x0E, 0x00) :> - (0x02, 0x0F, 0x00) :> - (0x02, 0x10, 0x00) :> - (0x02, 0x11, 0x00) :> - (0x02, 0x12, 0x00) :> - (0x02, 0x13, 0x00) :> - (0x02, 0x14, 0x00) :> - (0x02, 0x15, 0x00) :> - (0x02, 0x16, 0x00) :> - (0x02, 0x17, 0x00) :> - (0x02, 0x18, 0x00) :> - (0x02, 0x19, 0x00) :> - (0x02, 0x1A, 0x00) :> - (0x02, 0x1B, 0x00) :> - (0x02, 0x1C, 0x00) :> - (0x02, 0x1D, 0x00) :> - (0x02, 0x1E, 0x00) :> - (0x02, 0x1F, 0x00) :> - (0x02, 0x20, 0x00) :> - (0x02, 0x21, 0x00) :> - (0x02, 0x22, 0x00) :> - (0x02, 0x23, 0x00) :> - (0x02, 0x24, 0x00) :> - (0x02, 0x25, 0x00) :> - (0x02, 0x26, 0x00) :> - (0x02, 0x27, 0x00) :> - (0x02, 0x28, 0x00) :> - (0x02, 0x29, 0x00) :> - (0x02, 0x2A, 0x00) :> - (0x02, 0x2B, 0x00) :> - (0x02, 0x2C, 0x00) :> - (0x02, 0x2D, 0x00) :> - (0x02, 0x2E, 0x00) :> - (0x02, 0x2F, 0x00) :> - (0x02, 0x31, 0x0B) :> - (0x02, 0x32, 0x0B) :> - (0x02, 0x33, 0x0B) :> - (0x02, 0x34, 0x0B) :> - (0x02, 0x35, 0x00) :> - (0x02, 0x36, 0x00) :> - (0x02, 0x37, 0x00) :> - (0x02, 0x38, 0xC0) :> - (0x02, 0x39, 0x89) :> - (0x02, 0x3A, 0x00) :> - (0x02, 0x3B, 0x00) :> - (0x02, 0x3C, 0x00) :> - (0x02, 0x3D, 0x00) :> - (0x02, 0x3E, 0x80) :> - (0x02, 0x47, 0x00) :> - (0x02, 0x48, 0x00) :> - (0x02, 0x49, 0x00) :> - (0x02, 0x4A, 0x00) :> - (0x02, 0x4B, 0x00) :> - (0x02, 0x4C, 0x00) :> - (0x02, 0x4D, 0x00) :> - (0x02, 0x4E, 0x00) :> - (0x02, 0x4F, 0x00) :> - (0x02, 0x50, 0x00) :> - (0x02, 0x51, 0x00) :> - (0x02, 0x52, 0x00) :> - (0x02, 0x53, 0x00) :> - (0x02, 0x54, 0x00) :> - (0x02, 0x55, 0x00) :> - (0x02, 0x56, 0x00) :> - (0x02, 0x57, 0x00) :> - (0x02, 0x58, 0x00) :> - (0x02, 0x59, 0x00) :> - (0x02, 0x5A, 0x00) :> - (0x02, 0x5B, 0x00) :> - (0x02, 0x5C, 0x00) :> - (0x02, 0x5D, 0x00) :> - (0x02, 0x5E, 0x00) :> - (0x02, 0x5F, 0x00) :> - (0x02, 0x60, 0x00) :> - (0x02, 0x61, 0x00) :> - (0x02, 0x62, 0x00) :> - (0x02, 0x63, 0x00) :> - (0x02, 0x64, 0x00) :> - (0x02, 0x65, 0x09) :> - (0x02, 0x66, 0x00) :> - (0x02, 0x67, 0x00) :> - (0x02, 0x68, 0x00) :> - (0x02, 0x69, 0x00) :> - (0x02, 0x6A, 0x00) :> - (0x02, 0x6B, 0x00) :> - (0x02, 0x6C, 0x00) :> - (0x02, 0x6D, 0x00) :> - (0x02, 0x6E, 0x00) :> - (0x02, 0x6F, 0x00) :> - (0x02, 0x70, 0x00) :> - (0x02, 0x71, 0x00) :> - (0x02, 0x72, 0x00) :> - (0x02, 0x8A, 0x00) :> - (0x02, 0x8B, 0x00) :> - (0x02, 0x8C, 0x00) :> - (0x02, 0x8D, 0x00) :> - (0x02, 0x8E, 0x00) :> - (0x02, 0x8F, 0x00) :> - (0x02, 0x90, 0x00) :> - (0x02, 0x91, 0x00) :> - (0x02, 0x92, 0x3F) :> - (0x02, 0x93, 0x2F) :> - (0x02, 0x94, 0x80) :> - (0x02, 0x96, 0x00) :> - (0x02, 0x97, 0x00) :> - (0x02, 0x99, 0x00) :> - (0x02, 0x9D, 0x00) :> - (0x02, 0x9E, 0x00) :> - (0x02, 0x9F, 0x00) :> - (0x02, 0xA9, 0x00) :> - (0x02, 0xAA, 0x00) :> - (0x02, 0xAB, 0x00) :> - (0x02, 0xB7, 0xFF) :> - (0x02, 0xBC, 0x00) :> - (0x03, 0x02, 0x00) :> - (0x03, 0x03, 0x00) :> - (0x03, 0x04, 0x00) :> - (0x03, 0x05, 0xD4) :> - (0x03, 0x06, 0x19) :> - (0x03, 0x07, 0x00) :> - (0x03, 0x08, 0x00) :> - (0x03, 0x09, 0x00) :> - (0x03, 0x0A, 0x00) :> - (0x03, 0x0B, 0xC8) :> - (0x03, 0x0C, 0x00) :> - (0x03, 0x0D, 0x00) :> - (0x03, 0x0E, 0x00) :> - (0x03, 0x0F, 0x00) :> - (0x03, 0x10, 0xD4) :> - (0x03, 0x11, 0x19) :> - (0x03, 0x12, 0x00) :> - (0x03, 0x13, 0x00) :> - (0x03, 0x14, 0x00) :> - (0x03, 0x15, 0x00) :> - (0x03, 0x16, 0xC8) :> - (0x03, 0x17, 0x00) :> - (0x03, 0x18, 0x00) :> - (0x03, 0x19, 0x00) :> - (0x03, 0x1A, 0x00) :> - (0x03, 0x1B, 0x00) :> - (0x03, 0x1C, 0x00) :> - (0x03, 0x1D, 0x00) :> - (0x03, 0x1E, 0x00) :> - (0x03, 0x1F, 0x00) :> - (0x03, 0x20, 0x00) :> - (0x03, 0x21, 0x00) :> - (0x03, 0x22, 0x00) :> - (0x03, 0x23, 0x00) :> - (0x03, 0x24, 0x00) :> - (0x03, 0x25, 0x00) :> - (0x03, 0x26, 0x00) :> - (0x03, 0x27, 0x00) :> - (0x03, 0x28, 0x00) :> - (0x03, 0x29, 0x00) :> - (0x03, 0x2A, 0x00) :> - (0x03, 0x2B, 0x00) :> - (0x03, 0x2C, 0x00) :> - (0x03, 0x2D, 0x00) :> - (0x03, 0x2E, 0x00) :> - (0x03, 0x2F, 0x00) :> - (0x03, 0x30, 0x00) :> - (0x03, 0x31, 0x00) :> - (0x03, 0x32, 0x00) :> - (0x03, 0x33, 0x00) :> - (0x03, 0x34, 0x00) :> - (0x03, 0x35, 0x00) :> - (0x03, 0x36, 0x00) :> - (0x03, 0x37, 0x00) :> - (0x03, 0x38, 0x00) :> - (0x03, 0x39, 0x1C) :> - (0x03, 0x3B, 0x55) :> - (0x03, 0x3C, 0x04) :> - (0x03, 0x3D, 0x00) :> - (0x03, 0x3E, 0x00) :> - (0x03, 0x3F, 0x00) :> - (0x03, 0x40, 0x00) :> - (0x03, 0x41, 0x55) :> - (0x03, 0x42, 0x04) :> - (0x03, 0x43, 0x00) :> - (0x03, 0x44, 0x00) :> - (0x03, 0x45, 0x00) :> - (0x03, 0x46, 0x00) :> - (0x03, 0x47, 0x00) :> - (0x03, 0x48, 0x00) :> - (0x03, 0x49, 0x00) :> - (0x03, 0x4A, 0x00) :> - (0x03, 0x4B, 0x00) :> - (0x03, 0x4C, 0x00) :> - (0x03, 0x4D, 0x00) :> - (0x03, 0x4E, 0x00) :> - (0x03, 0x4F, 0x00) :> - (0x03, 0x50, 0x00) :> - (0x03, 0x51, 0x00) :> - (0x03, 0x52, 0x00) :> - (0x03, 0x53, 0x00) :> - (0x03, 0x54, 0x00) :> - (0x03, 0x55, 0x00) :> - (0x03, 0x56, 0x00) :> - (0x03, 0x57, 0x00) :> - (0x03, 0x58, 0x00) :> - (0x03, 0x59, 0x00) :> - (0x03, 0x5A, 0x00) :> - (0x03, 0x5B, 0x00) :> - (0x03, 0x5C, 0x00) :> - (0x03, 0x5D, 0x00) :> - (0x03, 0x5E, 0x00) :> - (0x03, 0x5F, 0x00) :> - (0x03, 0x60, 0x00) :> - (0x03, 0x61, 0x00) :> - (0x03, 0x62, 0x00) :> - (0x04, 0x87, 0x00) :> - (0x05, 0x08, 0x00) :> - (0x05, 0x09, 0x00) :> - (0x05, 0x0A, 0x00) :> - (0x05, 0x0B, 0x00) :> - (0x05, 0x0C, 0x00) :> - (0x05, 0x0D, 0x00) :> - (0x05, 0x0E, 0x00) :> - (0x05, 0x0F, 0x00) :> - (0x05, 0x10, 0x00) :> - (0x05, 0x11, 0x00) :> - (0x05, 0x12, 0x00) :> - (0x05, 0x13, 0x00) :> - (0x05, 0x15, 0x00) :> - (0x05, 0x16, 0x00) :> - (0x05, 0x17, 0x00) :> - (0x05, 0x18, 0x00) :> - (0x05, 0x19, 0x00) :> - (0x05, 0x1A, 0x00) :> - (0x05, 0x1B, 0x00) :> - (0x05, 0x1C, 0x00) :> - (0x05, 0x1D, 0x00) :> - (0x05, 0x1E, 0x00) :> - (0x05, 0x1F, 0x00) :> - (0x05, 0x21, 0x2B) :> - (0x05, 0x2A, 0x00) :> - (0x05, 0x2B, 0x01) :> - (0x05, 0x2C, 0x0F) :> - (0x05, 0x2D, 0x03) :> - (0x05, 0x2E, 0x00) :> - (0x05, 0x2F, 0x00) :> - (0x05, 0x31, 0x00) :> - (0x05, 0x32, 0x00) :> - (0x05, 0x33, 0x04) :> - (0x05, 0x34, 0x00) :> - (0x05, 0x35, 0x01) :> - (0x05, 0x36, 0x06) :> - (0x05, 0x37, 0x00) :> - (0x05, 0x38, 0x00) :> - (0x05, 0x39, 0x00) :> - (0x05, 0x3D, 0x0A) :> - (0x05, 0x3E, 0x06) :> - (0x05, 0x88, 0x00) :> - (0x05, 0x89, 0x0C) :> - (0x05, 0x8A, 0x00) :> - (0x05, 0x8B, 0x00) :> - (0x05, 0x8C, 0x00) :> - (0x05, 0x8D, 0x00) :> - (0x05, 0x9B, 0x18) :> - (0x05, 0x9C, 0x0C) :> - (0x05, 0x9D, 0x00) :> - (0x05, 0x9E, 0x00) :> - (0x05, 0x9F, 0x00) :> - (0x05, 0xA0, 0x00) :> - (0x05, 0xA1, 0x00) :> - (0x05, 0xA2, 0x00) :> - (0x05, 0xA4, 0x20) :> - (0x05, 0xA5, 0x00) :> - (0x05, 0xA6, 0x00) :> - (0x05, 0xAC, 0x00) :> - (0x05, 0xAD, 0x00) :> - (0x05, 0xAE, 0x00) :> - (0x05, 0xB1, 0x00) :> - (0x05, 0xB2, 0x00) :> - (0x08, 0x02, 0x35) :> - (0x08, 0x03, 0x05) :> - (0x08, 0x04, 0x01) :> - (0x08, 0x05, 0x00) :> - (0x08, 0x06, 0x00) :> - (0x08, 0x07, 0x00) :> - (0x08, 0x08, 0x00) :> - (0x08, 0x09, 0x00) :> - (0x08, 0x0A, 0x00) :> - (0x08, 0x0B, 0x00) :> - (0x08, 0x0C, 0x00) :> - (0x08, 0x0D, 0x00) :> - (0x08, 0x0E, 0x00) :> - (0x08, 0x0F, 0x00) :> - (0x08, 0x10, 0x00) :> - (0x08, 0x11, 0x00) :> - (0x08, 0x12, 0x00) :> - (0x08, 0x13, 0x00) :> - (0x08, 0x14, 0x00) :> - (0x08, 0x15, 0x00) :> - (0x08, 0x16, 0x00) :> - (0x08, 0x17, 0x00) :> - (0x08, 0x18, 0x00) :> - (0x08, 0x19, 0x00) :> - (0x08, 0x1A, 0x00) :> - (0x08, 0x1B, 0x00) :> - (0x08, 0x1C, 0x00) :> - (0x08, 0x1D, 0x00) :> - (0x08, 0x1E, 0x00) :> - (0x08, 0x1F, 0x00) :> - (0x08, 0x20, 0x00) :> - (0x08, 0x21, 0x00) :> - (0x08, 0x22, 0x00) :> - (0x08, 0x23, 0x00) :> - (0x08, 0x24, 0x00) :> - (0x08, 0x25, 0x00) :> - (0x08, 0x26, 0x00) :> - (0x08, 0x27, 0x00) :> - (0x08, 0x28, 0x00) :> - (0x08, 0x29, 0x00) :> - (0x08, 0x2A, 0x00) :> - (0x08, 0x2B, 0x00) :> - (0x08, 0x2C, 0x00) :> - (0x08, 0x2D, 0x00) :> - (0x08, 0x2E, 0x00) :> - (0x08, 0x2F, 0x00) :> - (0x08, 0x30, 0x00) :> - (0x08, 0x31, 0x00) :> - (0x08, 0x32, 0x00) :> - (0x08, 0x33, 0x00) :> - (0x08, 0x34, 0x00) :> - (0x08, 0x35, 0x00) :> - (0x08, 0x36, 0x00) :> - (0x08, 0x37, 0x00) :> - (0x08, 0x38, 0x00) :> - (0x08, 0x39, 0x00) :> - (0x08, 0x3A, 0x00) :> - (0x08, 0x3B, 0x00) :> - (0x08, 0x3C, 0x00) :> - (0x08, 0x3D, 0x00) :> - (0x08, 0x3E, 0x00) :> - (0x08, 0x3F, 0x00) :> - (0x08, 0x40, 0x00) :> - (0x08, 0x41, 0x00) :> - (0x08, 0x42, 0x00) :> - (0x08, 0x43, 0x00) :> - (0x08, 0x44, 0x00) :> - (0x08, 0x45, 0x00) :> - (0x08, 0x46, 0x00) :> - (0x08, 0x47, 0x00) :> - (0x08, 0x48, 0x00) :> - (0x08, 0x49, 0x00) :> - (0x08, 0x4A, 0x00) :> - (0x08, 0x4B, 0x00) :> - (0x08, 0x4C, 0x00) :> - (0x08, 0x4D, 0x00) :> - (0x08, 0x4E, 0x00) :> - (0x08, 0x4F, 0x00) :> - (0x08, 0x50, 0x00) :> - (0x08, 0x51, 0x00) :> - (0x08, 0x52, 0x00) :> - (0x08, 0x53, 0x00) :> - (0x08, 0x54, 0x00) :> - (0x08, 0x55, 0x00) :> - (0x08, 0x56, 0x00) :> - (0x08, 0x57, 0x00) :> - (0x08, 0x58, 0x00) :> - (0x08, 0x59, 0x00) :> - (0x08, 0x5A, 0x00) :> - (0x08, 0x5B, 0x00) :> - (0x08, 0x5C, 0x00) :> - (0x08, 0x5D, 0x00) :> - (0x08, 0x5E, 0x00) :> - (0x08, 0x5F, 0x00) :> - (0x08, 0x60, 0x00) :> - (0x08, 0x61, 0x00) :> - (0x09, 0x0E, 0x02) :> - (0x09, 0x43, 0x01) :> - (0x09, 0x49, 0x00) :> - (0x09, 0x4A, 0x00) :> - (0x09, 0x4E, 0x49) :> - (0x09, 0x4F, 0xF2) :> - (0x09, 0x5E, 0x00) :> - (0x0A, 0x02, 0x00) :> - (0x0A, 0x03, 0x03) :> - (0x0A, 0x04, 0x00) :> - (0x0A, 0x05, 0x03) :> - (0x0A, 0x14, 0x00) :> - (0x0A, 0x1A, 0x00) :> - (0x0A, 0x20, 0x00) :> - (0x0A, 0x26, 0x00) :> - (0x0A, 0x2C, 0x00) :> - (0x0A, 0x38, 0x00) :> - (0x0A, 0x39, 0x00) :> - (0x0A, 0x3A, 0x00) :> - (0x0A, 0x3C, 0x00) :> - (0x0A, 0x3D, 0x00) :> - (0x0A, 0x3E, 0x00) :> - (0x0A, 0x40, 0x00) :> - (0x0A, 0x41, 0x00) :> - (0x0A, 0x42, 0x00) :> - (0x0A, 0x44, 0x00) :> - (0x0A, 0x45, 0x00) :> - (0x0A, 0x46, 0x00) :> - (0x0A, 0x48, 0x00) :> - (0x0A, 0x49, 0x00) :> - (0x0A, 0x4A, 0x00) :> - (0x0A, 0x4C, 0x00) :> - (0x0A, 0x4D, 0x00) :> - (0x0A, 0x4E, 0x00) :> - (0x0A, 0x4F, 0x00) :> - (0x0A, 0x50, 0x00) :> - (0x0A, 0x51, 0x00) :> - (0x0A, 0x52, 0x00) :> - (0x0A, 0x53, 0x00) :> - (0x0A, 0x54, 0x00) :> - (0x0A, 0x55, 0x00) :> - (0x0A, 0x56, 0x00) :> - (0x0A, 0x57, 0x00) :> - (0x0A, 0x58, 0x00) :> - (0x0A, 0x59, 0x00) :> - (0x0A, 0x5A, 0x00) :> - (0x0A, 0x5B, 0x00) :> - (0x0A, 0x5C, 0x00) :> - (0x0A, 0x5D, 0x00) :> - (0x0A, 0x5E, 0x00) :> - (0x0A, 0x5F, 0x00) :> - (0x0B, 0x44, 0x0F) :> - (0x0B, 0x46, 0x00) :> - (0x0B, 0x47, 0x0F) :> - (0x0B, 0x48, 0x0F) :> - (0x0B, 0x4A, 0x1C) :> - (0x0B, 0x57, 0x0E) :> - (0x0B, 0x58, 0x01) :> - (0x0C, 0x02, 0x03) :> - (0x0C, 0x03, 0x00) :> - (0x0C, 0x07, 0x00) :> - (0x0C, 0x08, 0x00) :> - Nil + (0x00, 0x06, 0x00) + :> (0x00, 0x07, 0x00) + :> (0x00, 0x08, 0x00) + :> (0x00, 0x0B, 0x68) + :> (0x00, 0x16, 0x02) + :> (0x00, 0x17, 0xDC) + :> (0x00, 0x18, 0xFF) + :> (0x00, 0x19, 0xFF) + :> (0x00, 0x1A, 0xFF) + :> (0x00, 0x2B, 0x02) + :> (0x00, 0x2C, 0x00) + :> (0x00, 0x2D, 0x00) + :> (0x00, 0x2E, 0x00) + :> (0x00, 0x2F, 0x00) + :> (0x00, 0x30, 0x00) + :> (0x00, 0x31, 0x00) + :> (0x00, 0x32, 0x00) + :> (0x00, 0x33, 0x00) + :> (0x00, 0x34, 0x00) + :> (0x00, 0x35, 0x00) + :> (0x00, 0x36, 0x00) + :> (0x00, 0x37, 0x00) + :> (0x00, 0x38, 0x00) + :> (0x00, 0x39, 0x00) + :> (0x00, 0x3A, 0x00) + :> (0x00, 0x3B, 0x00) + :> (0x00, 0x3C, 0x00) + :> (0x00, 0x3D, 0x00) + :> (0x00, 0x3E, 0x00) + :> (0x00, 0x3F, 0x00) + :> (0x00, 0x40, 0x04) + :> (0x00, 0x41, 0x00) + :> (0x00, 0x42, 0x00) + :> (0x00, 0x43, 0x00) + :> (0x00, 0x44, 0x00) + :> (0x00, 0x45, 0x0C) + :> (0x00, 0x46, 0x00) + :> (0x00, 0x47, 0x00) + :> (0x00, 0x48, 0x00) + :> (0x00, 0x49, 0x00) + :> (0x00, 0x4A, 0x00) + :> (0x00, 0x4B, 0x00) + :> (0x00, 0x4C, 0x00) + :> (0x00, 0x4D, 0x00) + :> (0x00, 0x4E, 0x00) + :> (0x00, 0x4F, 0x00) + :> (0x00, 0x50, 0x0F) + :> (0x00, 0x51, 0x00) + :> (0x00, 0x52, 0x00) + :> (0x00, 0x53, 0x00) + :> (0x00, 0x54, 0x00) + :> (0x00, 0x55, 0x00) + :> (0x00, 0x56, 0x00) + :> (0x00, 0x57, 0x00) + :> (0x00, 0x58, 0x00) + :> (0x00, 0x59, 0x00) + :> (0x00, 0x5A, 0x00) + :> (0x00, 0x5B, 0x00) + :> (0x00, 0x5C, 0x00) + :> (0x00, 0x5D, 0x00) + :> (0x00, 0x5E, 0x00) + :> (0x00, 0x5F, 0x00) + :> (0x00, 0x60, 0x00) + :> (0x00, 0x61, 0x00) + :> (0x00, 0x62, 0x00) + :> (0x00, 0x63, 0x00) + :> (0x00, 0x64, 0x00) + :> (0x00, 0x65, 0x00) + :> (0x00, 0x66, 0x00) + :> (0x00, 0x67, 0x00) + :> (0x00, 0x68, 0x00) + :> (0x00, 0x69, 0x00) + :> (0x00, 0x92, 0x00) + :> (0x00, 0x93, 0x00) + :> (0x00, 0x95, 0x00) + :> (0x00, 0x96, 0x00) + :> (0x00, 0x98, 0x00) + :> (0x00, 0x9A, 0x00) + :> (0x00, 0x9B, 0x00) + :> (0x00, 0x9D, 0x00) + :> (0x00, 0x9E, 0x00) + :> (0x00, 0xA0, 0x00) + :> (0x00, 0xA2, 0x00) + :> (0x00, 0xA9, 0x00) + :> (0x00, 0xAA, 0x00) + :> (0x00, 0xAB, 0x00) + :> (0x00, 0xAC, 0x00) + :> (0x00, 0xE5, 0x01) + :> (0x00, 0xEA, 0x00) + :> (0x00, 0xEB, 0x00) + :> (0x00, 0xEC, 0x00) + :> (0x00, 0xED, 0x00) + :> (0x01, 0x02, 0x01) + :> (0x01, 0x03, 0x06) + :> (0x01, 0x04, 0x09) + :> (0x01, 0x05, 0x3E) + :> (0x01, 0x06, 0x18) + :> (0x01, 0x08, 0x06) + :> (0x01, 0x09, 0x09) + :> (0x01, 0x0A, 0x3E) + :> (0x01, 0x0B, 0x18) + :> (0x01, 0x0D, 0x01) + :> (0x01, 0x0E, 0x09) + :> (0x01, 0x0F, 0x3B) + :> (0x01, 0x10, 0x28) + :> (0x01, 0x12, 0x01) + :> (0x01, 0x13, 0x09) + :> (0x01, 0x14, 0x3B) + :> (0x01, 0x15, 0x28) + :> (0x01, 0x17, 0x01) + :> (0x01, 0x18, 0x09) + :> (0x01, 0x19, 0x3B) + :> (0x01, 0x1A, 0x28) + :> (0x01, 0x1C, 0x01) + :> (0x01, 0x1D, 0x09) + :> (0x01, 0x1E, 0x3B) + :> (0x01, 0x1F, 0x28) + :> (0x01, 0x21, 0x01) + :> (0x01, 0x22, 0x09) + :> (0x01, 0x23, 0x3B) + :> (0x01, 0x24, 0x28) + :> (0x01, 0x26, 0x01) + :> (0x01, 0x27, 0x09) + :> (0x01, 0x28, 0x3B) + :> (0x01, 0x29, 0x28) + :> (0x01, 0x2B, 0x01) + :> (0x01, 0x2C, 0x09) + :> (0x01, 0x2D, 0x3B) + :> (0x01, 0x2E, 0x28) + :> (0x01, 0x30, 0x01) + :> (0x01, 0x31, 0x09) + :> (0x01, 0x32, 0x3B) + :> (0x01, 0x33, 0x28) + :> (0x01, 0x35, 0x02) + :> (0x01, 0x36, 0x09) + :> (0x01, 0x37, 0x3E) + :> (0x01, 0x38, 0x19) + :> (0x01, 0x3A, 0x06) + :> (0x01, 0x3B, 0x09) + :> (0x01, 0x3C, 0x3E) + :> (0x01, 0x3D, 0x19) + :> (0x01, 0x3F, 0x00) + :> (0x01, 0x40, 0x00) + :> (0x01, 0x41, 0x40) + :> (0x01, 0x42, 0xFF) + :> (0x02, 0x06, 0x00) + :> (0x02, 0x08, 0x00) + :> (0x02, 0x09, 0x00) + :> (0x02, 0x0A, 0x00) + :> (0x02, 0x0B, 0x00) + :> (0x02, 0x0C, 0x00) + :> (0x02, 0x0D, 0x00) + :> (0x02, 0x0E, 0x00) + :> (0x02, 0x0F, 0x00) + :> (0x02, 0x10, 0x00) + :> (0x02, 0x11, 0x00) + :> (0x02, 0x12, 0x00) + :> (0x02, 0x13, 0x00) + :> (0x02, 0x14, 0x00) + :> (0x02, 0x15, 0x00) + :> (0x02, 0x16, 0x00) + :> (0x02, 0x17, 0x00) + :> (0x02, 0x18, 0x00) + :> (0x02, 0x19, 0x00) + :> (0x02, 0x1A, 0x00) + :> (0x02, 0x1B, 0x00) + :> (0x02, 0x1C, 0x00) + :> (0x02, 0x1D, 0x00) + :> (0x02, 0x1E, 0x00) + :> (0x02, 0x1F, 0x00) + :> (0x02, 0x20, 0x00) + :> (0x02, 0x21, 0x00) + :> (0x02, 0x22, 0x00) + :> (0x02, 0x23, 0x00) + :> (0x02, 0x24, 0x00) + :> (0x02, 0x25, 0x00) + :> (0x02, 0x26, 0x00) + :> (0x02, 0x27, 0x00) + :> (0x02, 0x28, 0x00) + :> (0x02, 0x29, 0x00) + :> (0x02, 0x2A, 0x00) + :> (0x02, 0x2B, 0x00) + :> (0x02, 0x2C, 0x00) + :> (0x02, 0x2D, 0x00) + :> (0x02, 0x2E, 0x00) + :> (0x02, 0x2F, 0x00) + :> (0x02, 0x31, 0x0B) + :> (0x02, 0x32, 0x0B) + :> (0x02, 0x33, 0x0B) + :> (0x02, 0x34, 0x0B) + :> (0x02, 0x35, 0x00) + :> (0x02, 0x36, 0x00) + :> (0x02, 0x37, 0x00) + :> (0x02, 0x38, 0xC0) + :> (0x02, 0x39, 0x89) + :> (0x02, 0x3A, 0x00) + :> (0x02, 0x3B, 0x00) + :> (0x02, 0x3C, 0x00) + :> (0x02, 0x3D, 0x00) + :> (0x02, 0x3E, 0x80) + :> (0x02, 0x47, 0x00) + :> (0x02, 0x48, 0x00) + :> (0x02, 0x49, 0x00) + :> (0x02, 0x4A, 0x00) + :> (0x02, 0x4B, 0x00) + :> (0x02, 0x4C, 0x00) + :> (0x02, 0x4D, 0x00) + :> (0x02, 0x4E, 0x00) + :> (0x02, 0x4F, 0x00) + :> (0x02, 0x50, 0x00) + :> (0x02, 0x51, 0x00) + :> (0x02, 0x52, 0x00) + :> (0x02, 0x53, 0x00) + :> (0x02, 0x54, 0x00) + :> (0x02, 0x55, 0x00) + :> (0x02, 0x56, 0x00) + :> (0x02, 0x57, 0x00) + :> (0x02, 0x58, 0x00) + :> (0x02, 0x59, 0x00) + :> (0x02, 0x5A, 0x00) + :> (0x02, 0x5B, 0x00) + :> (0x02, 0x5C, 0x00) + :> (0x02, 0x5D, 0x00) + :> (0x02, 0x5E, 0x00) + :> (0x02, 0x5F, 0x00) + :> (0x02, 0x60, 0x00) + :> (0x02, 0x61, 0x00) + :> (0x02, 0x62, 0x00) + :> (0x02, 0x63, 0x00) + :> (0x02, 0x64, 0x00) + :> (0x02, 0x65, 0x09) + :> (0x02, 0x66, 0x00) + :> (0x02, 0x67, 0x00) + :> (0x02, 0x68, 0x00) + :> (0x02, 0x69, 0x00) + :> (0x02, 0x6A, 0x00) + :> (0x02, 0x6B, 0x00) + :> (0x02, 0x6C, 0x00) + :> (0x02, 0x6D, 0x00) + :> (0x02, 0x6E, 0x00) + :> (0x02, 0x6F, 0x00) + :> (0x02, 0x70, 0x00) + :> (0x02, 0x71, 0x00) + :> (0x02, 0x72, 0x00) + :> (0x02, 0x8A, 0x00) + :> (0x02, 0x8B, 0x00) + :> (0x02, 0x8C, 0x00) + :> (0x02, 0x8D, 0x00) + :> (0x02, 0x8E, 0x00) + :> (0x02, 0x8F, 0x00) + :> (0x02, 0x90, 0x00) + :> (0x02, 0x91, 0x00) + :> (0x02, 0x92, 0x3F) + :> (0x02, 0x93, 0x2F) + :> (0x02, 0x94, 0x80) + :> (0x02, 0x96, 0x00) + :> (0x02, 0x97, 0x00) + :> (0x02, 0x99, 0x00) + :> (0x02, 0x9D, 0x00) + :> (0x02, 0x9E, 0x00) + :> (0x02, 0x9F, 0x00) + :> (0x02, 0xA9, 0x00) + :> (0x02, 0xAA, 0x00) + :> (0x02, 0xAB, 0x00) + :> (0x02, 0xB7, 0xFF) + :> (0x02, 0xBC, 0x00) + :> (0x03, 0x02, 0x00) + :> (0x03, 0x03, 0x00) + :> (0x03, 0x04, 0x00) + :> (0x03, 0x05, 0xD4) + :> (0x03, 0x06, 0x19) + :> (0x03, 0x07, 0x00) + :> (0x03, 0x08, 0x00) + :> (0x03, 0x09, 0x00) + :> (0x03, 0x0A, 0x00) + :> (0x03, 0x0B, 0xC8) + :> (0x03, 0x0C, 0x00) + :> (0x03, 0x0D, 0x00) + :> (0x03, 0x0E, 0x00) + :> (0x03, 0x0F, 0x00) + :> (0x03, 0x10, 0xD4) + :> (0x03, 0x11, 0x19) + :> (0x03, 0x12, 0x00) + :> (0x03, 0x13, 0x00) + :> (0x03, 0x14, 0x00) + :> (0x03, 0x15, 0x00) + :> (0x03, 0x16, 0xC8) + :> (0x03, 0x17, 0x00) + :> (0x03, 0x18, 0x00) + :> (0x03, 0x19, 0x00) + :> (0x03, 0x1A, 0x00) + :> (0x03, 0x1B, 0x00) + :> (0x03, 0x1C, 0x00) + :> (0x03, 0x1D, 0x00) + :> (0x03, 0x1E, 0x00) + :> (0x03, 0x1F, 0x00) + :> (0x03, 0x20, 0x00) + :> (0x03, 0x21, 0x00) + :> (0x03, 0x22, 0x00) + :> (0x03, 0x23, 0x00) + :> (0x03, 0x24, 0x00) + :> (0x03, 0x25, 0x00) + :> (0x03, 0x26, 0x00) + :> (0x03, 0x27, 0x00) + :> (0x03, 0x28, 0x00) + :> (0x03, 0x29, 0x00) + :> (0x03, 0x2A, 0x00) + :> (0x03, 0x2B, 0x00) + :> (0x03, 0x2C, 0x00) + :> (0x03, 0x2D, 0x00) + :> (0x03, 0x2E, 0x00) + :> (0x03, 0x2F, 0x00) + :> (0x03, 0x30, 0x00) + :> (0x03, 0x31, 0x00) + :> (0x03, 0x32, 0x00) + :> (0x03, 0x33, 0x00) + :> (0x03, 0x34, 0x00) + :> (0x03, 0x35, 0x00) + :> (0x03, 0x36, 0x00) + :> (0x03, 0x37, 0x00) + :> (0x03, 0x38, 0x00) + :> (0x03, 0x39, 0x1C) + :> (0x03, 0x3B, 0x55) + :> (0x03, 0x3C, 0x04) + :> (0x03, 0x3D, 0x00) + :> (0x03, 0x3E, 0x00) + :> (0x03, 0x3F, 0x00) + :> (0x03, 0x40, 0x00) + :> (0x03, 0x41, 0x55) + :> (0x03, 0x42, 0x04) + :> (0x03, 0x43, 0x00) + :> (0x03, 0x44, 0x00) + :> (0x03, 0x45, 0x00) + :> (0x03, 0x46, 0x00) + :> (0x03, 0x47, 0x00) + :> (0x03, 0x48, 0x00) + :> (0x03, 0x49, 0x00) + :> (0x03, 0x4A, 0x00) + :> (0x03, 0x4B, 0x00) + :> (0x03, 0x4C, 0x00) + :> (0x03, 0x4D, 0x00) + :> (0x03, 0x4E, 0x00) + :> (0x03, 0x4F, 0x00) + :> (0x03, 0x50, 0x00) + :> (0x03, 0x51, 0x00) + :> (0x03, 0x52, 0x00) + :> (0x03, 0x53, 0x00) + :> (0x03, 0x54, 0x00) + :> (0x03, 0x55, 0x00) + :> (0x03, 0x56, 0x00) + :> (0x03, 0x57, 0x00) + :> (0x03, 0x58, 0x00) + :> (0x03, 0x59, 0x00) + :> (0x03, 0x5A, 0x00) + :> (0x03, 0x5B, 0x00) + :> (0x03, 0x5C, 0x00) + :> (0x03, 0x5D, 0x00) + :> (0x03, 0x5E, 0x00) + :> (0x03, 0x5F, 0x00) + :> (0x03, 0x60, 0x00) + :> (0x03, 0x61, 0x00) + :> (0x03, 0x62, 0x00) + :> (0x04, 0x87, 0x00) + :> (0x05, 0x08, 0x00) + :> (0x05, 0x09, 0x00) + :> (0x05, 0x0A, 0x00) + :> (0x05, 0x0B, 0x00) + :> (0x05, 0x0C, 0x00) + :> (0x05, 0x0D, 0x00) + :> (0x05, 0x0E, 0x00) + :> (0x05, 0x0F, 0x00) + :> (0x05, 0x10, 0x00) + :> (0x05, 0x11, 0x00) + :> (0x05, 0x12, 0x00) + :> (0x05, 0x13, 0x00) + :> (0x05, 0x15, 0x00) + :> (0x05, 0x16, 0x00) + :> (0x05, 0x17, 0x00) + :> (0x05, 0x18, 0x00) + :> (0x05, 0x19, 0x00) + :> (0x05, 0x1A, 0x00) + :> (0x05, 0x1B, 0x00) + :> (0x05, 0x1C, 0x00) + :> (0x05, 0x1D, 0x00) + :> (0x05, 0x1E, 0x00) + :> (0x05, 0x1F, 0x00) + :> (0x05, 0x21, 0x2B) + :> (0x05, 0x2A, 0x00) + :> (0x05, 0x2B, 0x01) + :> (0x05, 0x2C, 0x0F) + :> (0x05, 0x2D, 0x03) + :> (0x05, 0x2E, 0x00) + :> (0x05, 0x2F, 0x00) + :> (0x05, 0x31, 0x00) + :> (0x05, 0x32, 0x00) + :> (0x05, 0x33, 0x04) + :> (0x05, 0x34, 0x00) + :> (0x05, 0x35, 0x01) + :> (0x05, 0x36, 0x06) + :> (0x05, 0x37, 0x00) + :> (0x05, 0x38, 0x00) + :> (0x05, 0x39, 0x00) + :> (0x05, 0x3D, 0x0A) + :> (0x05, 0x3E, 0x06) + :> (0x05, 0x88, 0x00) + :> (0x05, 0x89, 0x0C) + :> (0x05, 0x8A, 0x00) + :> (0x05, 0x8B, 0x00) + :> (0x05, 0x8C, 0x00) + :> (0x05, 0x8D, 0x00) + :> (0x05, 0x9B, 0x18) + :> (0x05, 0x9C, 0x0C) + :> (0x05, 0x9D, 0x00) + :> (0x05, 0x9E, 0x00) + :> (0x05, 0x9F, 0x00) + :> (0x05, 0xA0, 0x00) + :> (0x05, 0xA1, 0x00) + :> (0x05, 0xA2, 0x00) + :> (0x05, 0xA4, 0x20) + :> (0x05, 0xA5, 0x00) + :> (0x05, 0xA6, 0x00) + :> (0x05, 0xAC, 0x00) + :> (0x05, 0xAD, 0x00) + :> (0x05, 0xAE, 0x00) + :> (0x05, 0xB1, 0x00) + :> (0x05, 0xB2, 0x00) + :> (0x08, 0x02, 0x35) + :> (0x08, 0x03, 0x05) + :> (0x08, 0x04, 0x01) + :> (0x08, 0x05, 0x00) + :> (0x08, 0x06, 0x00) + :> (0x08, 0x07, 0x00) + :> (0x08, 0x08, 0x00) + :> (0x08, 0x09, 0x00) + :> (0x08, 0x0A, 0x00) + :> (0x08, 0x0B, 0x00) + :> (0x08, 0x0C, 0x00) + :> (0x08, 0x0D, 0x00) + :> (0x08, 0x0E, 0x00) + :> (0x08, 0x0F, 0x00) + :> (0x08, 0x10, 0x00) + :> (0x08, 0x11, 0x00) + :> (0x08, 0x12, 0x00) + :> (0x08, 0x13, 0x00) + :> (0x08, 0x14, 0x00) + :> (0x08, 0x15, 0x00) + :> (0x08, 0x16, 0x00) + :> (0x08, 0x17, 0x00) + :> (0x08, 0x18, 0x00) + :> (0x08, 0x19, 0x00) + :> (0x08, 0x1A, 0x00) + :> (0x08, 0x1B, 0x00) + :> (0x08, 0x1C, 0x00) + :> (0x08, 0x1D, 0x00) + :> (0x08, 0x1E, 0x00) + :> (0x08, 0x1F, 0x00) + :> (0x08, 0x20, 0x00) + :> (0x08, 0x21, 0x00) + :> (0x08, 0x22, 0x00) + :> (0x08, 0x23, 0x00) + :> (0x08, 0x24, 0x00) + :> (0x08, 0x25, 0x00) + :> (0x08, 0x26, 0x00) + :> (0x08, 0x27, 0x00) + :> (0x08, 0x28, 0x00) + :> (0x08, 0x29, 0x00) + :> (0x08, 0x2A, 0x00) + :> (0x08, 0x2B, 0x00) + :> (0x08, 0x2C, 0x00) + :> (0x08, 0x2D, 0x00) + :> (0x08, 0x2E, 0x00) + :> (0x08, 0x2F, 0x00) + :> (0x08, 0x30, 0x00) + :> (0x08, 0x31, 0x00) + :> (0x08, 0x32, 0x00) + :> (0x08, 0x33, 0x00) + :> (0x08, 0x34, 0x00) + :> (0x08, 0x35, 0x00) + :> (0x08, 0x36, 0x00) + :> (0x08, 0x37, 0x00) + :> (0x08, 0x38, 0x00) + :> (0x08, 0x39, 0x00) + :> (0x08, 0x3A, 0x00) + :> (0x08, 0x3B, 0x00) + :> (0x08, 0x3C, 0x00) + :> (0x08, 0x3D, 0x00) + :> (0x08, 0x3E, 0x00) + :> (0x08, 0x3F, 0x00) + :> (0x08, 0x40, 0x00) + :> (0x08, 0x41, 0x00) + :> (0x08, 0x42, 0x00) + :> (0x08, 0x43, 0x00) + :> (0x08, 0x44, 0x00) + :> (0x08, 0x45, 0x00) + :> (0x08, 0x46, 0x00) + :> (0x08, 0x47, 0x00) + :> (0x08, 0x48, 0x00) + :> (0x08, 0x49, 0x00) + :> (0x08, 0x4A, 0x00) + :> (0x08, 0x4B, 0x00) + :> (0x08, 0x4C, 0x00) + :> (0x08, 0x4D, 0x00) + :> (0x08, 0x4E, 0x00) + :> (0x08, 0x4F, 0x00) + :> (0x08, 0x50, 0x00) + :> (0x08, 0x51, 0x00) + :> (0x08, 0x52, 0x00) + :> (0x08, 0x53, 0x00) + :> (0x08, 0x54, 0x00) + :> (0x08, 0x55, 0x00) + :> (0x08, 0x56, 0x00) + :> (0x08, 0x57, 0x00) + :> (0x08, 0x58, 0x00) + :> (0x08, 0x59, 0x00) + :> (0x08, 0x5A, 0x00) + :> (0x08, 0x5B, 0x00) + :> (0x08, 0x5C, 0x00) + :> (0x08, 0x5D, 0x00) + :> (0x08, 0x5E, 0x00) + :> (0x08, 0x5F, 0x00) + :> (0x08, 0x60, 0x00) + :> (0x08, 0x61, 0x00) + :> (0x09, 0x0E, 0x02) + :> (0x09, 0x43, 0x01) + :> (0x09, 0x49, 0x00) + :> (0x09, 0x4A, 0x00) + :> (0x09, 0x4E, 0x49) + :> (0x09, 0x4F, 0xF2) + :> (0x09, 0x5E, 0x00) + :> (0x0A, 0x02, 0x00) + :> (0x0A, 0x03, 0x03) + :> (0x0A, 0x04, 0x00) + :> (0x0A, 0x05, 0x03) + :> (0x0A, 0x14, 0x00) + :> (0x0A, 0x1A, 0x00) + :> (0x0A, 0x20, 0x00) + :> (0x0A, 0x26, 0x00) + :> (0x0A, 0x2C, 0x00) + :> (0x0A, 0x38, 0x00) + :> (0x0A, 0x39, 0x00) + :> (0x0A, 0x3A, 0x00) + :> (0x0A, 0x3C, 0x00) + :> (0x0A, 0x3D, 0x00) + :> (0x0A, 0x3E, 0x00) + :> (0x0A, 0x40, 0x00) + :> (0x0A, 0x41, 0x00) + :> (0x0A, 0x42, 0x00) + :> (0x0A, 0x44, 0x00) + :> (0x0A, 0x45, 0x00) + :> (0x0A, 0x46, 0x00) + :> (0x0A, 0x48, 0x00) + :> (0x0A, 0x49, 0x00) + :> (0x0A, 0x4A, 0x00) + :> (0x0A, 0x4C, 0x00) + :> (0x0A, 0x4D, 0x00) + :> (0x0A, 0x4E, 0x00) + :> (0x0A, 0x4F, 0x00) + :> (0x0A, 0x50, 0x00) + :> (0x0A, 0x51, 0x00) + :> (0x0A, 0x52, 0x00) + :> (0x0A, 0x53, 0x00) + :> (0x0A, 0x54, 0x00) + :> (0x0A, 0x55, 0x00) + :> (0x0A, 0x56, 0x00) + :> (0x0A, 0x57, 0x00) + :> (0x0A, 0x58, 0x00) + :> (0x0A, 0x59, 0x00) + :> (0x0A, 0x5A, 0x00) + :> (0x0A, 0x5B, 0x00) + :> (0x0A, 0x5C, 0x00) + :> (0x0A, 0x5D, 0x00) + :> (0x0A, 0x5E, 0x00) + :> (0x0A, 0x5F, 0x00) + :> (0x0B, 0x44, 0x0F) + :> (0x0B, 0x46, 0x00) + :> (0x0B, 0x47, 0x0F) + :> (0x0B, 0x48, 0x0F) + :> (0x0B, 0x4A, 0x1C) + :> (0x0B, 0x57, 0x0E) + :> (0x0B, 0x58, 0x01) + :> (0x0C, 0x02, 0x03) + :> (0x0C, 0x03, 0x00) + :> (0x0C, 0x07, 0x00) + :> (0x0C, 0x08, 0x00) + :> Nil diff --git a/bittide/src/Bittide/ClockControl/Si539xSpi.hs b/bittide/src/Bittide/ClockControl/Si539xSpi.hs index ad97a1a95..6610af758 100644 --- a/bittide/src/Bittide/ClockControl/Si539xSpi.hs +++ b/bittide/src/Bittide/ClockControl/Si539xSpi.hs @@ -1,18 +1,17 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 -{-# OPTIONS_GHC -fconstraint-solver-iterations=15 #-} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=15 #-} module Bittide.ClockControl.Si539xSpi where -import Clash.Prelude hiding (PeriodToCycles) import Clash.Cores.SPI +import Clash.Prelude hiding (PeriodToCycles) import Data.Maybe @@ -25,10 +24,13 @@ import Clash.Cores.Xilinx.DcFifo -- | The Si539X chips use "Page"s to increase their address space. type Page = Byte + -- | Different memory location depending on the current 'Page'. type Address = Byte + -- | Indicates that the interface producing this is currently Busy and will not respond to inputs. type Busy = Bool + -- | Indicates tgat the interface producing this value has captured the input. type Acknowledge = Bool @@ -37,16 +39,18 @@ type RegisterEntry = (Page, Address, Byte) -- | Used to read from or write to a register on a Si539x chip via SPI. data RegisterOperation = RegisterOperation - { regPage :: Page - -- ^ Page at which to perform the read or write. - , regAddress :: Address - -- ^ Address at which to perform the read or write - , regWrite :: Maybe Byte - -- ^ @Nothing@ for a read operation, @Just byte@ to write @byte@ to this 'Page' and 'Address'. - } deriving (Show, Generic, NFDataX) - --- | Contains the configuration for an Si539x chip, explicitly differentiates between --- the configuration preamble, configuration and configuration postamble. + { regPage :: Page + -- ^ Page at which to perform the read or write. + , regAddress :: Address + -- ^ Address at which to perform the read or write + , regWrite :: Maybe Byte + -- ^ @Nothing@ for a read operation, @Just byte@ to write @byte@ to this 'Page' and 'Address'. + } + deriving (Show, Generic, NFDataX) + +{- | Contains the configuration for an Si539x chip, explicitly differentiates between +the configuration preamble, configuration and configuration postamble. +-} data Si539xRegisterMap preambleEntries configEntries postambleEntries = Si539xRegisterMap { configPreamble :: Vec preambleEntries RegisterEntry -- ^ Configuration preamble @@ -56,63 +60,67 @@ data Si539xRegisterMap preambleEntries configEntries postambleEntries = Si539xRe -- ^ Configuration postamble } --- | Operations supported by the Si539x chip, @BurstWrite@ is omitted because the --- current SPI core does not support writing a variable number of bytes while slave select --- is low. +{- | Operations supported by the Si539x chip, @BurstWrite@ is omitted because the +current SPI core does not support writing a variable number of bytes while slave select +is low. +-} data SpiCommand - = SetAddress Address - -- ^ Sets the selected register 'Address' on the Si539x chip. - | WriteData Byte - -- ^ Writes data to the selected 'Address' on the selected 'Page'. - | ReadData - -- ^ Reads data from the selected 'Address' on the selected 'Page'. - | WriteDataInc Byte - -- ^ Writes data to the selected 'Address' on the selected 'Page' and increments the 'Address'. - | ReadDataInc - -- ^ Reads data from the selected 'Address' on the selected 'Page' and increments the 'Address'. - deriving Eq + = -- | Sets the selected register 'Address' on the Si539x chip. + SetAddress Address + | -- | Writes data to the selected 'Address' on the selected 'Page'. + WriteData Byte + | -- | Reads data from the selected 'Address' on the selected 'Page'. + ReadData + | -- | Writes data to the selected 'Address' on the selected 'Page' and increments the 'Address'. + WriteDataInc Byte + | -- | Reads data from the selected 'Address' on the selected 'Page' and increments the 'Address'. + ReadDataInc + deriving (Eq) -- | Converts an 'SpiCommand' to the corresponding bytes to be sent over SPI. spiCommandToBytes :: SpiCommand -> Bytes 2 spiCommandToBytes = \case - SetAddress bv -> pack (0b0000_0000 :: Byte, bv) - WriteData bv -> pack (0b0100_0000 :: Byte, bv) - ReadData -> pack (0b1000_0000 :: Byte, 0 :: Byte) + SetAddress bv -> pack (0b0000_0000 :: Byte, bv) + WriteData bv -> pack (0b0100_0000 :: Byte, bv) + ReadData -> pack (0b1000_0000 :: Byte, 0 :: Byte) WriteDataInc bv -> pack (0b0110_0000 :: Byte, bv) - ReadDataInc -> pack (0b1000_0000 :: Byte, 0 :: Byte) - -- BurstWrite bv -> pack (0b1110_0000 :: Byte, bv) BurstWrite is not supported by the current SPI core. + ReadDataInc -> pack (0b1000_0000 :: Byte, 0 :: Byte) + +-- BurstWrite bv -> pack (0b1110_0000 :: Byte, bv) BurstWrite is not supported by the current SPI core. -- | State of the configuration circuit in 'si539xSpi'. data ConfigState dom entries - = WaitForReady Bool - -- ^ Continuously read from 'Address' 0xFE at any 'Page', if this operations returns - -- 0x0F twice in a row, the device is considered to be ready for operation. - | ResetDriver Bool - -- ^ Always after a @WaitForReady False@ state, we reset the SPI driver to make sure - -- it first sets the page and address again. - | FetchReg (Index entries) - -- ^ Fetches the 'RegisterEntry' at the 'Index' to be written to the @Si539x@ chip. - | WriteEntry (Index entries) - -- ^ Writes the 'RegisterEntry' at the 'Index' to the @Si539x@ chip. - | ReadEntry (Index entries) - -- ^ Checks if the 'RegisterEntry' at the 'Index' was correctly written to the @Si539x@ chip. - | Error (Index entries) - -- ^ The 'RegisterEntry' at the 'Index' was not correctly written to the @Si539x@ chip. - | WaitForLock - -- ^ Continuously read from 'Address' 0x0C at 'Page' 0x00 until it returns bit 3 is 0. - | Finished - -- ^ All entries in the 'Si539xRegisterMap' were correctly written to the @Si539x@ chip. - | Wait (Index (PeriodToCycles dom (Milliseconds 300))) (Index entries) - -- ^ Waits for the Si539X to be calibrated after writing the configuration preamble from 'Si539xRegisterMap'. + = -- | Continuously read from 'Address' 0xFE at any 'Page', if this operations returns + -- 0x0F twice in a row, the device is considered to be ready for operation. + WaitForReady Bool + | -- | Always after a @WaitForReady False@ state, we reset the SPI driver to make sure + -- it first sets the page and address again. + ResetDriver Bool + | -- | Fetches the 'RegisterEntry' at the 'Index' to be written to the @Si539x@ chip. + FetchReg (Index entries) + | -- | Writes the 'RegisterEntry' at the 'Index' to the @Si539x@ chip. + WriteEntry (Index entries) + | -- | Checks if the 'RegisterEntry' at the 'Index' was correctly written to the @Si539x@ chip. + ReadEntry (Index entries) + | -- | The 'RegisterEntry' at the 'Index' was not correctly written to the @Si539x@ chip. + Error (Index entries) + | -- | Continuously read from 'Address' 0x0C at 'Page' 0x00 until it returns bit 3 is 0. + WaitForLock + | -- | All entries in the 'Si539xRegisterMap' were correctly written to the @Si539x@ chip. + Finished + | -- | Waits for the Si539X to be calibrated after writing the configuration preamble from 'Si539xRegisterMap'. + Wait (Index (PeriodToCycles dom (Milliseconds 300))) (Index entries) deriving (Show, Generic, NFDataX, Eq) instance ( 1 <= entries , KnownNat (DomainPeriod dom) - , KnownNat entries ) => BitPack (ConfigState dom entries) + , KnownNat entries + ) => + BitPack (ConfigState dom entries) -- | Utility function to retrieve the entry 'Index' from the 'ConfigState'. -getStateAddress :: KnownNat entries => ConfigState dom entries -> Index entries +getStateAddress :: (KnownNat entries) => ConfigState dom entries -> Index entries getStateAddress = \case WaitForReady _ -> 0 ResetDriver _ -> 0 @@ -124,17 +132,20 @@ getStateAddress = \case Finished -> maxBound Wait _ i -> i --- | SPI interface for a @Si539x@ clock generator chip with an initial configuration. --- This component will first write and verify the initial configuration before becoming --- available for external circuitry. For an interface that does not initially configure the --- chip, see 'si539xDriver'. +{- | SPI interface for a @Si539x@ clock generator chip with an initial configuration. +This component will first write and verify the initial configuration before becoming +available for external circuitry. For an interface that does not initially configure the +chip, see 'si539xDriver'. +-} si539xSpi :: - forall dom preambleEntries configEntries postambleEntries minTargetPeriodPs . + forall dom preambleEntries configEntries postambleEntries minTargetPeriodPs. ( HiddenClockResetEnable dom - , KnownNat preambleEntries, 1 <= preambleEntries + , KnownNat preambleEntries + , 1 <= preambleEntries , KnownNat configEntries , KnownNat postambleEntries - , 1 <= (preambleEntries + configEntries + postambleEntries)) => + , 1 <= (preambleEntries + configEntries + postambleEntries) + ) => -- | Initial configuration for the @Si539x@ chip. Si539xRegisterMap preambleEntries configEntries postambleEntries -> -- | Minimum period of the SPI clock frequency for the SPI clock divider. @@ -150,9 +161,9 @@ si539xSpi :: ( Signal dom (Maybe Byte) , Signal dom Busy , Signal dom (ConfigState dom (preambleEntries + configEntries + postambleEntries)) - , ( "SCK" ::: Signal dom Bool + , ( "SCK" ::: Signal dom Bool , "MOSI" ::: Signal dom Bit - , "SS" ::: Signal dom Bool + , "SS" ::: Signal dom Bool ) ) si539xSpi Si539xRegisterMap{..} minTargetPs@SNat externalOperation miso = @@ -161,7 +172,7 @@ si539xSpi Si539xRegisterMap{..} minTargetPs@SNat externalOperation miso = (driverByte, driverBusy, spiOut) = withReset driverReset si539xSpiDriver minTargetPs spiOperation miso driverReset = forceReset $ holdTrue d3 $ flip fmap configState $ \case ResetDriver _ -> True - _ -> False + _ -> False romOut = rom (configPreamble ++ config ++ configPostamble) romAddress romAddress = bitCoerce . getStateAddress <$> configState @@ -169,76 +180,76 @@ si539xSpi Si539xRegisterMap{..} minTargetPs@SNat externalOperation miso = (configState, spiOperation, configBusy, configByte) = mealyB go (WaitForReady False) (romOut, externalOperation, driverByte, driverBusy) - go currentState ((regPage,regAddress,byte), extSpi, spiByte, spiBusy) = + go currentState ((regPage, regAddress, byte), extSpi, spiByte, spiBusy) = (nextState, (currentState, spiOp, busy, returnedByte)) where isConfigEntry i = (natToNum @preambleEntries) <= i && i < (natToNum @(preambleEntries + configEntries)) nextState = case (currentState, spiByte) of - (WaitForReady False, Just 0x0F) -> ResetDriver True - (WaitForReady True, Just 0x0F) -> FetchReg 0 - (WaitForReady _, Just _) -> ResetDriver False - (ResetDriver b, _) -> WaitForReady b - - (FetchReg i, _) -> WriteEntry i + (WaitForReady False, Just 0x0F) -> ResetDriver True + (WaitForReady True, Just 0x0F) -> FetchReg 0 + (WaitForReady _, Just _) -> ResetDriver False + (ResetDriver b, _) -> WaitForReady b + (FetchReg i, _) -> WriteEntry i (WriteEntry i, Just _) - | i == maxBound -> WaitForLock + | i == maxBound -> WaitForLock | i == (natToNum @preambleEntries - 1) -> Wait @dom 0 i - | isConfigEntry i -> ReadEntry i - | otherwise -> FetchReg (succ i) - + | isConfigEntry i -> ReadEntry i + | otherwise -> FetchReg (succ i) (ReadEntry i, Just b) - | b == byte -> FetchReg (succ i) - | otherwise -> Error i - (Wait ((==maxBound) -> True) i, _) -> FetchReg (succ i) - (Wait j i, _) -> Wait (succ j) i - (WaitForLock, Just 0) -> Finished - (WaitForReady _, _) -> currentState - (WaitForLock, _ ) -> currentState - (WriteEntry _, _) -> currentState - (ReadEntry _, _) -> currentState - (Finished , _) -> currentState - (Error _ , _) -> currentState + | b == byte -> FetchReg (succ i) + | otherwise -> Error i + (Wait ((== maxBound) -> True) i, _) -> FetchReg (succ i) + (Wait j i, _) -> Wait (succ j) i + (WaitForLock, Just 0) -> Finished + (WaitForReady _, _) -> currentState + (WaitForLock, _) -> currentState + (WriteEntry _, _) -> currentState + (ReadEntry _, _) -> currentState + (Finished, _) -> currentState + (Error _, _) -> currentState spiOp = case currentState of WaitForReady _ -> Just RegisterOperation{regPage = 0x00, regAddress = 0xFE, regWrite = Nothing} - ResetDriver _ -> Nothing - FetchReg _ -> Nothing - WriteEntry _ -> Just RegisterOperation{regPage, regAddress, regWrite = Just byte} - ReadEntry _ -> Just RegisterOperation{regPage, regAddress, regWrite = Nothing} - Wait _ _ -> Nothing - WaitForLock -> Just RegisterOperation{regPage = 0, regAddress = 0xC0, regWrite = Nothing} - Finished -> extSpi - Error _ -> extSpi + ResetDriver _ -> Nothing + FetchReg _ -> Nothing + WriteEntry _ -> Just RegisterOperation{regPage, regAddress, regWrite = Just byte} + ReadEntry _ -> Just RegisterOperation{regPage, regAddress, regWrite = Nothing} + Wait _ _ -> Nothing + WaitForLock -> Just RegisterOperation{regPage = 0, regAddress = 0xC0, regWrite = Nothing} + Finished -> extSpi + Error _ -> extSpi (busy, returnedByte) = case currentState of Finished -> (spiBusy, spiByte) - Error _ -> (spiBusy, spiByte) - _ -> (True, Nothing) + Error _ -> (spiBusy, spiByte) + _ -> (True, Nothing) --- | Keeps track of the current 'Page' and 'Address' of the @Si539x@ chip as well as --- the current communication cycle. +{- | Keeps track of the current 'Page' and 'Address' of the @Si539x@ chip as well as +the current communication cycle. +-} data DriverState dom = DriverState - { currentPage :: Maybe Page + { currentPage :: Maybe Page -- ^ Current 'Page' of the @Si539x@ chip. - , currentAddress :: Maybe Address + , currentAddress :: Maybe Address -- ^ Current 'Address' of the @Si539x@ chip. - , currentOp :: Maybe RegisterOperation + , currentOp :: Maybe RegisterOperation -- ^ Current communication transaction. , commandAcknowledged :: Acknowledge -- ^ Whether or not the current transaction has already been acknowledged. , storedByte :: Maybe Byte -- ^ Data we have received from the SPI interface. - , idleCycles :: Index (PeriodToCycles dom (Nanoseconds 95)) + , idleCycles :: Index (PeriodToCycles dom (Nanoseconds 95)) -- ^ After communication, slave select must be high for at least 95ns. } deriving (Generic, NFDataX) --- | Circuitry that controls an SPI core based on a state machine that ensures communication --- transactions with an @Si539x@ chip are executed correctly. It makes sure communication --- operations target the right register and communication operations are spaced correctly. +{- | Circuitry that controls an SPI core based on a state machine that ensures communication +transactions with an @Si539x@ chip are executed correctly. It makes sure communication +operations target the right register and communication operations are spaced correctly. +-} si539xSpiDriver :: - forall dom minTargetPeriodPs . + forall dom minTargetPeriodPs. (HiddenClockResetEnable dom) => -- | Minimum period of the SPI clock frequency for the SPI clock divider. SNat minTargetPeriodPs -> @@ -252,85 +263,91 @@ si539xSpiDriver :: -- 3. Outgoing SPI signals: (SCK, MOSI, SS) ( Signal dom (Maybe Byte) , Signal dom Busy - , ( "SCK" ::: Signal dom Bool + , ( "SCK" ::: Signal dom Bool , "MOSI" ::: Signal dom Bit - , "SS" ::: Signal dom Bool + , "SS" ::: Signal dom Bool ) ) si539xSpiDriver SNat incomingOpS miso = (fromSlave, decoderBusy, spiOut) where spiOut = (sck, mosi, ss) - (sck, mosi, ss, spiBusyS, acknowledge, receivedData) = spiMaster SPIMode0 - (SNat @(Max 1 (DivRU (PeriodToCycles dom minTargetPeriodPs) 2))) d1 spiWrite miso + (sck, mosi, ss, spiBusyS, acknowledge, receivedData) = + spiMaster + SPIMode0 + (SNat @(Max 1 (DivRU (PeriodToCycles dom minTargetPeriodPs) 2))) + d1 + spiWrite + miso (spiWrite, decoderBusy, fromSlave) = mealyB go defDriverState (incomingOpS, spiBusyS, acknowledge, receivedData) - defDriverState = DriverState - { currentPage = Nothing - , currentAddress = Nothing - , currentOp = Nothing - , commandAcknowledged = False - , storedByte = Nothing - , idleCycles = maxBound - } + defDriverState = + DriverState + { currentPage = Nothing + , currentAddress = Nothing + , currentOp = Nothing + , commandAcknowledged = False + , storedByte = Nothing + , idleCycles = maxBound + } go :: DriverState dom -> - (Maybe RegisterOperation , Busy, Acknowledge, Maybe (Bytes 2)) -> + (Maybe RegisterOperation, Busy, Acknowledge, Maybe (Bytes 2)) -> (DriverState dom, (Maybe (Bytes 2), Busy, Maybe Byte)) - go currentState@(currentOp -> Nothing) (incomingOp,_,_, _) = + go currentState@(currentOp -> Nothing) (incomingOp, _, _, _) = (currentState{currentOp = incomingOp}, (Nothing, False, storedByte currentState)) - go currentState@DriverState{..} (_, spiBusy, spiAck, receivedBytes) = - (nextState, (output, True, storedByte)) + (nextState, (output, True, storedByte)) where RegisterOperation{..} = fromJust currentOp samePage = currentPage == Just regPage sameAddr = currentAddress == Just regAddress (spiCommand, nextOp, outBytes) = case (samePage, sameAddr, regWrite) of - (True , True , Just byte) -> (WriteData byte,Nothing, receivedBytes) - (True , True , Nothing ) -> (ReadData,Nothing, receivedBytes) - (True , False, _ ) -> (SetAddress regAddress,currentOp, Nothing) - (False, _ , _ ) - | currentAddress == Just 1 -> (WriteData regPage,currentOp, Nothing) - | otherwise -> (SetAddress 1,currentOp, Nothing) - - (nextPage,nextAddress) = case (currentPage, currentAddress, spiCommand) of - (_,Just 1, WriteData newPage) -> (Just newPage, currentAddress) - (_, _, SetAddress newAddr) -> (currentPage, Just newAddr) - _ -> (currentPage, currentAddress) + (True, True, Just byte) -> (WriteData byte, Nothing, receivedBytes) + (True, True, Nothing) -> (ReadData, Nothing, receivedBytes) + (True, False, _) -> (SetAddress regAddress, currentOp, Nothing) + (False, _, _) + | currentAddress == Just 1 -> (WriteData regPage, currentOp, Nothing) + | otherwise -> (SetAddress 1, currentOp, Nothing) + + (nextPage, nextAddress) = case (currentPage, currentAddress, spiCommand) of + (_, Just 1, WriteData newPage) -> (Just newPage, currentAddress) + (_, _, SetAddress newAddr) -> (currentPage, Just newAddr) + _ -> (currentPage, currentAddress) updateIdleCycles | spiBusy = idleCycles | otherwise = satPred SatZero idleCycles nextState - | commandAcknowledged && not spiBusy && isNothing storedByte - = DriverState nextPage nextAddress nextOp False (fmap resize outBytes) maxBound - | otherwise - = currentState - { commandAcknowledged = spiAck || commandAcknowledged - , idleCycles = updateIdleCycles - , storedByte = fmap resize outBytes - } + | commandAcknowledged && not spiBusy && isNothing storedByte = + DriverState nextPage nextAddress nextOp False (fmap resize outBytes) maxBound + | otherwise = + currentState + { commandAcknowledged = spiAck || commandAcknowledged + , idleCycles = updateIdleCycles + , storedByte = fmap resize outBytes + } spiBytes = spiCommandToBytes spiCommand output = orNothing (not commandAcknowledged && idleCycles == 0) spiBytes - {-# NOINLINE si539xSpiDriver #-} -- TODO: Look into replacing dcFifo with XPM_CDC_Handshake. --- | Consumes 'SpeedChange's produced by a clock control algorithm and produces a --- 'RegisterOperation' for the 'si539xSpi' core. Consumption rate of 'SpeedUp's and --- 'SlowDown' depends on the availability of the SPI core. Uses 'dcFifo' with a depth --- of 16 elements for clock domain crossing. This is an alternative to controlling the --- FINC / FDEC pins directly, the advantages are that we already have to use SPI --- to configure the chips, so we require less wiring / IO, and we don´t have to concern --- ourselves with the timing requirements for controlling FINC / FDEC directly. The only --- downside is that it is not as instantaneous as controlling the pins. + +{- | Consumes 'SpeedChange's produced by a clock control algorithm and produces a +'RegisterOperation' for the 'si539xSpi' core. Consumption rate of 'SpeedUp's and +'SlowDown' depends on the availability of the SPI core. Uses 'dcFifo' with a depth +of 16 elements for clock domain crossing. This is an alternative to controlling the +FINC / FDEC pins directly, the advantages are that we already have to use SPI +to configure the chips, so we require less wiring / IO, and we don´t have to concern +ourselves with the timing requirements for controlling FINC / FDEC directly. The only +downside is that it is not as instantaneous as controlling the pins. +-} spiFrequencyController :: - forall domCallisto domSpi freqIncrementRange freqDecrementRange . + forall domCallisto domSpi freqIncrementRange freqDecrementRange. (KnownDomain domCallisto, KnownDomain domSpi) => -- | The number of times we can increment the frequency from its initial value. SNat freqIncrementRange -> @@ -354,54 +371,68 @@ spiFrequencyController :: Signal domSpi Busy -> -- | Outgoing 'RegisterOperation'. Signal domSpi (Maybe RegisterOperation) -spiFrequencyController SNat SNat - clkCallisto rstCallisto enCallisto - clkSpi rstSpi enSpi - speedChange spiBusy = spiOp - where - fifoIn = - mux - (speedChange .==. pure NoChange .||. not <$> fromEnable enCallisto) - (pure Nothing) - (Just <$> speedChange) - - FifoOut{..} = - dcFifo (defConfig @4) clkCallisto rstCallisto clkSpi rstSpi fifoIn readEnable - - (spiOp, readEnable) = withClockResetEnable clkSpi rstSpi enSpi - mealyB go initState (spiBusy, isEmpty, fifoData) - - initState :: (Bool, Index (1 + freqIncrementRange + freqDecrementRange)) - initState = (False, natToNum @freqIncrementRange) - - go (fifoValid, stepCount) (spiBusyGo, isEmptyGo, fifoDataGo) = - ((readEnableGo, stepCountNext), (spiOpGo, readEnableGo)) +spiFrequencyController + SNat + SNat + clkCallisto + rstCallisto + enCallisto + clkSpi + rstSpi + enSpi + speedChange + spiBusy = spiOp where - readEnableGo = not (isEmptyGo || spiBusyGo) - stepCountNext = case (fifoValid, spiBusyGo, fifoDataGo) of - (True, False, SpeedUp) -> satSucc SatBound stepCount - (True, False, SlowDown) -> satPred SatBound stepCount - _ -> stepCount - - spiOpGo = case (fifoValid, fifoDataGo, stepCount == maxBound, stepCount == minBound) of - (True, SpeedUp, False, _) -> - Just RegisterOperation{regPage = 0x00, regAddress = 0x1D, regWrite = Just 1} - (True, SlowDown, _, False) -> - Just RegisterOperation{regPage = 0x00, regAddress = 0x1D, regWrite = Just 2} - _ -> Nothing - + fifoIn = + mux + (speedChange .==. pure NoChange .||. not <$> fromEnable enCallisto) + (pure Nothing) + (Just <$> speedChange) + + FifoOut{..} = + dcFifo (defConfig @4) clkCallisto rstCallisto clkSpi rstSpi fifoIn readEnable + + (spiOp, readEnable) = + withClockResetEnable + clkSpi + rstSpi + enSpi + mealyB + go + initState + (spiBusy, isEmpty, fifoData) + + initState :: (Bool, Index (1 + freqIncrementRange + freqDecrementRange)) + initState = (False, natToNum @freqIncrementRange) + + go (fifoValid, stepCount) (spiBusyGo, isEmptyGo, fifoDataGo) = + ((readEnableGo, stepCountNext), (spiOpGo, readEnableGo)) + where + readEnableGo = not (isEmptyGo || spiBusyGo) + stepCountNext = case (fifoValid, spiBusyGo, fifoDataGo) of + (True, False, SpeedUp) -> satSucc SatBound stepCount + (True, False, SlowDown) -> satPred SatBound stepCount + _ -> stepCount + + spiOpGo = case (fifoValid, fifoDataGo, stepCount == maxBound, stepCount == minBound) of + (True, SpeedUp, False, _) -> + Just RegisterOperation{regPage = 0x00, regAddress = 0x1D, regWrite = Just 1} + (True, SlowDown, _, False) -> + Just RegisterOperation{regPage = 0x00, regAddress = 0x1D, regWrite = Just 2} + _ -> Nothing {-# NOINLINE spiFrequencyController #-} --- | When this component receives @True@, it will hold it for @holdCycles@ number of --- clock cycles. This implementation does not scale well to large values for @holdCycles@ --- because it uses 'Vec' internally. +{- | When this component receives @True@, it will hold it for @holdCycles@ number of +clock cycles. This implementation does not scale well to large values for @holdCycles@ +because it uses 'Vec' internally. +-} holdTrue :: - forall dom holdCycles . + forall dom holdCycles. (HiddenClockResetEnable dom, 1 <= holdCycles) => SNat holdCycles -> Signal dom Bool -> Signal dom Bool holdTrue SNat = mealy go (repeat False) where - go :: 1 <= holdCycles => Vec holdCycles Bool -> Bool -> (Vec holdCycles Bool, Bool) + go :: (1 <= holdCycles) => Vec holdCycles Bool -> Bool -> (Vec holdCycles Bool, Bool) go state@(Cons _ _) input = (takeI $ input :> state, fold (||) state) diff --git a/bittide/src/Bittide/ClockControl/StabilityChecker.hs b/bittide/src/Bittide/ClockControl/StabilityChecker.hs index 04a70ed3d..ef01ccb0e 100644 --- a/bittide/src/Bittide/ClockControl/StabilityChecker.hs +++ b/bittide/src/Bittide/ClockControl/StabilityChecker.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} @@ -10,28 +9,29 @@ module Bittide.ClockControl.StabilityChecker where import Clash.Prelude -import Foreign.Storable (Storable(..)) +import Foreign.Storable (Storable (..)) import Bittide.ClockControl (RelDataCount, targetDataCount) import Bittide.ClockControl.Callisto.Util (dataCountToSigned) import Bittide.ClockControl.Foreign.Sizes -- | Stability results to be returned by the 'stabilityChecker'. -data StabilityIndication = - StabilityIndication - { stable :: Bool - -- ^ Indicates stability of the signal over time. - , settled :: Bool - -- ^ Indicates whether the signal is stable and close to - -- 'targetDataCount'. - } +data StabilityIndication = StabilityIndication + { stable :: Bool + -- ^ Indicates stability of the signal over time. + , settled :: Bool + -- ^ Indicates whether the signal is stable and close to + -- 'targetDataCount'. + } deriving (Generic, NFDataX, BitPack) -type instance SizeOf StabilityIndication = - SizeOf Int +type instance + SizeOf StabilityIndication = + SizeOf Int -type instance Alignment StabilityIndication = - Alignment Int +type instance + Alignment StabilityIndication = + Alignment Int instance Storable StabilityIndication where sizeOf = const $ natToNum @(SizeOf StabilityIndication) @@ -44,22 +44,23 @@ instance Storable StabilityIndication where poke p = pokeByteOff p 0 . toC where - toC :: StabilityIndication -> Int - toC (StabilityIndication x y) = - let xBit = if x then (`setBit` 0) else (`clearBit` 0) - yBit = if y then (`setBit` 1) else (`clearBit` 1) - in xBit $ yBit zeroBits + toC :: StabilityIndication -> Int + toC (StabilityIndication x y) = + let xBit = if x then (`setBit` 0) else (`clearBit` 0) + yBit = if y then (`setBit` 1) else (`clearBit` 1) + in xBit $ yBit zeroBits --- | Checks whether the @Signal@ of buffer occupancies from an elastic --- buffer is stable and settled. The @Signal@ is considered to be --- stable, if it stays within a @margin@ of the target buffer --- occupancy for @framesize@ number of cycles. If the current buffer --- occupancies exceed that margin, then the target is updated to the --- current buffer occupancy. The @Signal@ is considered to be settled, --- if it is stable and close (within @margin@) to the global target --- data count. +{- | Checks whether the @Signal@ of buffer occupancies from an elastic +buffer is stable and settled. The @Signal@ is considered to be +stable, if it stays within a @margin@ of the target buffer +occupancy for @framesize@ number of cycles. If the current buffer +occupancies exceed that margin, then the target is updated to the +current buffer occupancy. The @Signal@ is considered to be settled, +if it is stable and close (within @margin@) to the global target +data count. +-} stabilityChecker :: - forall dom margin framesize n . + forall dom margin framesize n. (HiddenClockResetEnable dom, 1 <= framesize, KnownNat n) => -- | Maximum number of elements the incoming buffer occupancy is -- allowed to deviate from the current @target@ for it to be @@ -82,7 +83,7 @@ stabilityChecker SNat SNat = mealy go (0, targetDataCount) newState :: (Index (framesize + 1), RelDataCount n) newState | withinMargin target input = (satSucc SatBound cnt, target) - | otherwise = (0, input) + | otherwise = (0, input) stable = withinMargin target input && cnt == maxBound settled = stable && withinMargin targetDataCount input diff --git a/bittide/src/Bittide/Counter.hs b/bittide/src/Bittide/Counter.hs index e85d7a4e7..008a85a92 100644 --- a/bittide/src/Bittide/Counter.hs +++ b/bittide/src/Bittide/Counter.hs @@ -2,72 +2,74 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Bittide.Counter - ( Active - , domainDiffCounter - , domainDiffCounterExt - ) where +module Bittide.Counter ( + Active, + domainDiffCounter, + domainDiffCounterExt, +) where import Clash.Explicit.Prelude import Clash.Cores.Xilinx.Xpm (xpmCdcGray) -import Clash.Sized.Extra (unsignedToSigned, concatUnsigneds) -import Clash.Explicit.Reset.Extra (Asserted(..), xpmResetSynchronizer) +import Clash.Explicit.Reset.Extra (Asserted (..), xpmResetSynchronizer) +import Clash.Sized.Extra (concatUnsigneds, unsignedToSigned) -- | State of 'domainDiffCounter' data DdcState - -- | In reset, or waiting for the incoming counter to change - = DdcInReset - -- | Counting and comparing with incoming domain - | DdcRunning (Unsigned 64) + = -- | In reset, or waiting for the incoming counter to change + DdcInReset + | -- | Counting and comparing with incoming domain + DdcRunning (Unsigned 64) deriving (Generic, NFDataX) -- | Indicates whether 'domainDiffCounter' is actively counting or still in reset. type Active = Bool --- | Determine speed differences between two domains. If the source domain is --- faster than the destination domain, the result will become larger. Vice versa, --- if the source domain is slower than the destination domain, the result will --- become smaller. This is analogous to what would happen to a FIFO's data count --- when continuously written to by the source domain and read from by the --- destination domain. To ease integration in control algorithms, this component --- makes sure it starts counting at zero. It also waits for the incoming counter --- to become active, i.e. non-zero, before starting to count itself. --- --- If both domains support initial values, 'domainDiffCounter' does not need to --- be reset. --- --- To reset this component, the reset should be asserted for at least one cycle in --- the source domain _plus_ four cycles in the destination domain. The reset in the --- destination domain should be deasserted at the same time or *after* the one in --- the source domain for glitchless operation. --- --- __N.B.__: --- This function will only work properly if the given domains are pretty close --- to another for a number of reasons: --- --- 1. It uses an 8-bit Gray counter internally for CDC --- --- 2. It uses one 64-bit counter in each domain --- --- 3. Its output is constrained to @Signed 32@ --- --- These values have been chosen such that: --- --- * The 64-bit counter only overflows once every 3000 years at 200 MHz --- --- * The 32-bit output only overflows after running at maximum divergence --- rate (100 ppm) at 200 MHz for 2 days. We expect systems to stabilize --- after a few milliseconds and reframing should nudge counters back to --- zero ever so often. --- +{- | Determine speed differences between two domains. If the source domain is +faster than the destination domain, the result will become larger. Vice versa, +if the source domain is slower than the destination domain, the result will +become smaller. This is analogous to what would happen to a FIFO's data count +when continuously written to by the source domain and read from by the +destination domain. To ease integration in control algorithms, this component +makes sure it starts counting at zero. It also waits for the incoming counter +to become active, i.e. non-zero, before starting to count itself. + +If both domains support initial values, 'domainDiffCounter' does not need to +be reset. + +To reset this component, the reset should be asserted for at least one cycle in +the source domain _plus_ four cycles in the destination domain. The reset in the +destination domain should be deasserted at the same time or *after* the one in +the source domain for glitchless operation. + +__N.B.__: + This function will only work properly if the given domains are pretty close + to another for a number of reasons: + + 1. It uses an 8-bit Gray counter internally for CDC + + 2. It uses one 64-bit counter in each domain + + 3. Its output is constrained to @Signed 32@ + + These values have been chosen such that: + + * The 64-bit counter only overflows once every 3000 years at 200 MHz + + * The 32-bit output only overflows after running at maximum divergence + rate (100 ppm) at 200 MHz for 2 days. We expect systems to stabilize + after a few milliseconds and reframing should nudge counters back to + zero ever so often. +-} domainDiffCounter :: - forall src dst . + forall src dst. ( KnownDomain src , KnownDomain dst ) => - Clock src -> Reset src -> - Clock dst -> Reset dst -> + Clock src -> + Reset src -> + Clock dst -> + Reset dst -> -- | Counter and boolean indicating whether the component is currently active Signal dst (Signed 32, Active) domainDiffCounter clkSrc rstSrc clkDst rstDst = @@ -78,15 +80,16 @@ domainDiffCounter clkSrc rstSrc clkDst rstDst = go :: DdcState -> Unsigned 64 -> (DdcState, (Signed 32, Bool)) go DdcInReset c1 - | c1 == 0 = (DdcInReset, (0, False)) + | c1 == 0 = (DdcInReset, (0, False)) | otherwise = (DdcRunning (c1 + 1), (0, True)) go (DdcRunning c0) c1 = (DdcRunning (c0 + 1), (c1 `subAndTruncate` c0, True)) subAndTruncate :: Unsigned 64 -> Unsigned 64 -> Signed 32 subAndTruncate c0 c1 = truncateB (unsignedToSigned c0 - unsignedToSigned c1) --- | A variant of 'domainDiffCounter' for determination of speed differences --- between two domains, but which are captured in another external domain. +{- | A variant of 'domainDiffCounter' for determination of speed differences +between two domains, but which are captured in another external domain. +-} domainDiffCounterExt :: forall ext src dst. ( KnownDomain ext @@ -96,77 +99,95 @@ domainDiffCounterExt :: , HasDefinedInitialValues src , HasDefinedInitialValues dst ) => - Clock ext -> Reset ext -> - Clock src -> Clock dst -> + Clock ext -> + Reset ext -> + Clock src -> + Clock dst -> Signal ext (Signed 32) -domainDiffCounterExt clkExt rstExt clkSrc clkDst = truncateB <$> - ((-) <$> extendedGrayCounter clkSrc <*> extendedGrayCounter clkDst) +domainDiffCounterExt clkExt rstExt clkSrc clkDst = + truncateB + <$> ((-) <$> extendedGrayCounter clkSrc <*> extendedGrayCounter clkDst) where -- 64 bits is enough for approximately 3 millenia @ 200 MHz - extendedGrayCounter :: KnownDomain dom => Clock dom -> Signal ext (Signed 65) + extendedGrayCounter :: (KnownDomain dom) => Clock dom -> Signal ext (Signed 65) extendedGrayCounter clk = - fmap unsignedToSigned - $ extendSuccCounter clkExt rstExt - $ xpmCdcGray clk clkExt counter + fmap unsignedToSigned + $ extendSuccCounter clkExt rstExt + $ xpmCdcGray clk clkExt counter where - counter = register - clk (xpmResetSynchronizer Deasserted clkExt clk rstExt) enableGen - (minBound :: Unsigned 8) - (satSucc SatWrap <$> counter) - --- | A counter that counts /up/, synchronized from the domain @src@ to domain @dst@. To --- reset this component, the reset should be asserted for at least one cycle in the --- source domain _plus_ four cycles in the destination domain. --- --- __N.B.__: This function uses an 8-bit Gray counter internally, and will therefore --- only work properly if both clock speeds are pretty close to one another. + counter = + register + clk + (xpmResetSynchronizer Deasserted clkExt clk rstExt) + enableGen + (minBound :: Unsigned 8) + (satSucc SatWrap <$> counter) + +{- | A counter that counts /up/, synchronized from the domain @src@ to domain @dst@. To +reset this component, the reset should be asserted for at least one cycle in the +source domain _plus_ four cycles in the destination domain. + +__N.B.__: This function uses an 8-bit Gray counter internally, and will therefore + only work properly if both clock speeds are pretty close to one another. +-} synchronizedSuccCounter :: - forall n src dst . + forall n src dst. ( KnownDomain src , KnownDomain dst , KnownNat n , 8 <= n ) => - Clock src -> Reset src -> - Clock dst -> Reset dst -> + Clock src -> + Reset src -> + Clock dst -> + Reset dst -> Signal dst (Unsigned n) synchronizedSuccCounter clkSrc rstSrc clkDst rstDst = - extendSuccCounter @8 @(n - 8) clkDst rstDst $ - xpmCdcGray @8 clkSrc clkDst counter + extendSuccCounter @8 @(n - 8) clkDst rstDst + $ xpmCdcGray @8 clkSrc clkDst counter where counter :: Signal src (Unsigned 8) counter = register clkSrc rstSrc enableGen 0 (counter + 1) -- | State of 'extendSuccCounter' data EscState m - -- | In reset, or waiting for an overflow - = EscInReset - -- | Counting - whenever an overflow occurs, this constructors field is upped - | EscRunning (Unsigned m) + = -- | In reset, or waiting for an overflow + EscInReset + | -- | Counting - whenever an overflow occurs, this constructors field is upped + EscRunning (Unsigned m) deriving (Generic, NFDataX) --- | Given a counter that counts /up/, extend the size of the counter. After its --- reset is deasserted, it will wait until it sees an overflow to ensure the --- counter is glitchless and always starts at 0. --- --- This can be used to extend computationally complex counter components, such as --- Gray counters. +{- | Given a counter that counts /up/, extend the size of the counter. After its +reset is deasserted, it will wait until it sees an overflow to ensure the +counter is glitchless and always starts at 0. + +This can be used to extend computationally complex counter components, such as +Gray counters. +-} extendSuccCounter :: - forall n m dom . + forall n m dom. ( KnownDomain dom , KnownNat n - , KnownNat m ) => - Clock dom -> Reset dom -> + , KnownNat m + ) => + Clock dom -> + Reset dom -> Signal dom (Unsigned n) -> Signal dom (Unsigned (m + n)) extendSuccCounter clk rst counterLower = - mealyB clk rst enableGen go EscInReset + mealyB + clk + rst + enableGen + go + EscInReset ( isFalling clk rst enableGen 0 (msb <$> counterLower) - , counterLower ) + , counterLower + ) where go :: EscState m -> (Bool, Unsigned n) -> (EscState m, Unsigned (m + n)) - go EscInReset (False, _) = (EscInReset, 0) - go EscInReset (True, n0) = (EscRunning 0, extend n0) + go EscInReset (False, _) = (EscInReset, 0) + go EscInReset (True, n0) = (EscRunning 0, extend n0) go (EscRunning m0) (overflow, n0) = (EscRunning m1, n1) where m1 = if overflow then m0 + 1 else m0 diff --git a/bittide/src/Bittide/DoubleBufferedRam.hs b/bittide/src/Bittide/DoubleBufferedRam.hs index 6bde10bd9..67df5cdf6 100644 --- a/bittide/src/Bittide/DoubleBufferedRam.hs +++ b/bittide/src/Bittide/DoubleBufferedRam.hs @@ -1,14 +1,12 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - -{-# OPTIONS_GHC -fconstraint-solver-iterations=7#-} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-} module Bittide.DoubleBufferedRam where @@ -16,7 +14,7 @@ import Clash.Prelude import Data.Constraint import Data.Maybe -import Protocols (Circuit (Circuit), CSignal, Df, Ack (Ack)) +import Protocols (Ack (Ack), CSignal, Circuit (Circuit), Df) import Protocols.Df (dataToMaybe) import Protocols.Wishbone @@ -43,39 +41,54 @@ instance (Show a, KnownNat n, Typeable a) => Show (ContentType n a) where nAnda = "(" <> show (natToNatural @n) <> " of type (" <> show (typeRep $ Proxy @a) <> "))" data InitialContent elements a where NonReloadable :: ContentType elements a -> InitialContent elements a - Reloadable :: ContentType elements a -> InitialContent elements a - Undefined :: (1 <= elements, KnownNat elements) => InitialContent elements a + Reloadable :: ContentType elements a -> InitialContent elements a + Undefined :: (1 <= elements, KnownNat elements) => InitialContent elements a -deriving instance (Show a, KnownNat elements, Typeable a) => Show (InitialContent elements a) +deriving instance + (Show a, KnownNat elements, Typeable a) => Show (InitialContent elements a) --- | Accepts 'InitialContents' and returns a 'blockRam' implementations initialized with --- the corresponding content. +{- | Accepts 'InitialContents' and returns a 'blockRam' implementations initialized with +the corresponding content. +-} initializedRam :: - forall dom n a . + forall dom n a. ( HiddenClockResetEnable dom - , KnownNat n, 1 <= n - , Paddable a) => + , KnownNat n + , 1 <= n + , Paddable a + ) => ContentType n a -> - ( Signal dom (Index n)-> + ( Signal dom (Index n) -> Signal dom (Maybe (Located n a)) -> - Signal dom a) + Signal dom a + ) initializedRam content rd wr = case content of - Vec vec -> blockRam vec rd wr - Blob blob -> bitCoerce <$> blockRamBlob blob rd (bitCoerce <$> wr) - BlobVec blobVec -> getDataBe @8 . RegisterBank <$> - bundle ((`blockRamBlob` rd) <$> blobVec <*> unbundle ((`splitWriteInBytes` maxBound) <$> wr)) + Vec vec -> blockRam vec rd wr + Blob blob -> bitCoerce <$> blockRamBlob blob rd (bitCoerce <$> wr) + BlobVec blobVec -> + getDataBe @8 + . RegisterBank + <$> bundle + ((`blockRamBlob` rd) <$> blobVec <*> unbundle ((`splitWriteInBytes` maxBound) <$> wr)) File fp -> bitCoerce <$> blockRamFile (SNat @n) fp rd (bitCoerce <$> wr) - FileVec fpVec -> getDataBe @8 . RegisterBank <$> - bundle ((\ fp -> blockRamFile (SNat @n) fp rd) - <$> fpVec - <*> unbundle ((`splitWriteInBytes` maxBound) <$> wr)) + FileVec fpVec -> + getDataBe @8 + . RegisterBank + <$> bundle + ( (\fp -> blockRamFile (SNat @n) fp rd) + <$> fpVec + <*> unbundle ((`splitWriteInBytes` maxBound) <$> wr) + ) contentGenerator :: - forall dom romSize targetSize a . + forall dom romSize targetSize a. ( HiddenClockResetEnable dom - , KnownNat targetSize, 1 <= targetSize - , KnownNat romSize, romSize <= targetSize - , Paddable a) => + , KnownNat targetSize + , 1 <= targetSize + , KnownNat romSize + , romSize <= targetSize + , Paddable a + ) => ContentType romSize a -> (Signal dom (Maybe (Located targetSize a)), Signal dom Bool) contentGenerator content = case compareSNat d1 (SNat @romSize) of @@ -91,11 +104,15 @@ contentGenerator content = case compareSNat d1 (SNat @romSize) of -- | Circuit wrapper around `wbStorageDP`. wbStorageDPC :: - forall dom depth awA awB . + forall dom depth awA awB. ( HiddenClockResetEnable dom - , KnownNat awA, 2 <= awA - , KnownNat awB, 2 <= awB - , KnownNat depth, 1 <= depth) => + , KnownNat awA + , 2 <= awA + , KnownNat awB + , 2 <= awB + , KnownNat depth + , 1 <= depth + ) => InitialContent depth (Bytes 4) -> Circuit (Wishbone dom 'Standard awA (Bytes 4), Wishbone dom 'Standard awB (Bytes 4)) @@ -104,30 +121,37 @@ wbStorageDPC content = Circuit go where go :: ( ( Signal dom (WishboneM2S awA 4 (BitVector 32)) - , Signal dom (WishboneM2S awB 4 (BitVector 32))) + , Signal dom (WishboneM2S awB 4 (BitVector 32)) + ) , () ) -> ( ( Signal dom (WishboneS2M (BitVector 32)) - , Signal dom (WishboneS2M (BitVector 32))) + , Signal dom (WishboneS2M (BitVector 32)) + ) , () ) - go ((m2sA, m2sB), ()) = ((s2mA, s2mB),()) + go ((m2sA, m2sB), ()) = ((s2mA, s2mB), ()) where (s2mA, s2mB) = wbStorageDP content m2sA m2sB --- | Dual-ported Wishbone storage element, essentially a wrapper for the single-ported version --- which priorities port A over port B. Transactions are not aborted, but when two transactions --- are initiated at the same time, port A will have priority. +{- | Dual-ported Wishbone storage element, essentially a wrapper for the single-ported version +which priorities port A over port B. Transactions are not aborted, but when two transactions +are initiated at the same time, port A will have priority. +-} wbStorageDP :: - forall dom depth awA awB . + forall dom depth awA awB. ( HiddenClockResetEnable dom - , KnownNat awA, 2 <= awA - , KnownNat awB, 2 <= awB - , KnownNat depth, 1 <= depth) => + , KnownNat awA + , 2 <= awA + , KnownNat awB + , 2 <= awB + , KnownNat depth + , 1 <= depth + ) => InitialContent depth (Bytes 4) -> Signal dom (WishboneM2S awA 4 (Bytes 4)) -> Signal dom (WishboneM2S awB 4 (Bytes 4)) -> - (Signal dom (WishboneS2M (Bytes 4)),Signal dom (WishboneS2M (Bytes 4))) + (Signal dom (WishboneS2M (Bytes 4)), Signal dom (WishboneS2M (Bytes 4))) wbStorageDP initial aM2S bM2S = (aS2M, bS2M) where storageOut = case lessThanMax @awA @awB @2 of @@ -141,27 +165,34 @@ wbStorageDP initial aM2S bM2S = (aS2M, bS2M) nextActive = selectNow <$> nowActive <*> aM2S <*> aS2M <*> bM2S <*> bS2M active WishboneM2S{busCycle, strobe} = busCycle && strobe terminated WishboneS2M{acknowledge, err} = acknowledge || err - selectNow aorb am2s as2m bm2s bs2m = + selectNow aorb am2s as2m bm2s bs2m = case (aorb, active am2s, terminated as2m, active bm2s, terminated bs2m) of - (_, True , _ , False, _ ) -> A - (_, False, _ , True , _ ) -> B - (A, True , True , True , _ ) -> B - (B, True , _ , True , True ) -> A - _ -> aorb - - (aS2M, bS2M) = unbundle $ mux (nowActive .==. pure A) - (bundle (storageOut, noTerminate <$> storageOut)) - (bundle (noTerminate <$> storageOut, storageOut)) + (_, True, _, False, _) -> A + (_, False, _, True, _) -> B + (A, True, True, True, _) -> B + (B, True, _, True, True) -> A + _ -> aorb + + (aS2M, bS2M) = + unbundle + $ mux + (nowActive .==. pure A) + (bundle (storageOut, noTerminate <$> storageOut)) + (bundle (noTerminate <$> storageOut, storageOut)) noTerminate wb = wb{acknowledge = False, err = False, retry = False, stall = False} --- | Wishbone storage element with 'Circuit' interface from "Protocols.Wishbone" that --- allows for word aligned reads and writes. +{- | Wishbone storage element with 'Circuit' interface from "Protocols.Wishbone" that +allows for word aligned reads and writes. +-} wbStorage :: - forall dom depth aw . + forall dom depth aw. ( HiddenClockResetEnable dom - , KnownNat aw, 2 <= aw - , KnownNat depth, 1 <= depth) => + , KnownNat aw + , 2 <= aw + , KnownNat depth + , 1 <= depth + ) => InitialContent depth (Bytes 4) -> Circuit (Wishbone dom 'Standard aw (Bytes 4)) () wbStorage initContent = Circuit $ \(m2s, ()) -> @@ -170,17 +201,20 @@ wbStorage initContent = Circuit $ \(m2s, ()) -> -- | Storage element with a single wishbone port. Allows for word-aligned addresses. wbStorage' :: - forall dom depth aw . + forall dom depth aw. ( HiddenClockResetEnable dom - , KnownNat aw, 2 <= aw - , KnownNat depth, 1 <= depth) => + , KnownNat aw + , 2 <= aw + , KnownNat depth + , 1 <= depth + ) => InitialContent depth (Bytes 4) -> Signal dom (WishboneM2S aw 4 (Bytes 4)) -> Signal dom (WishboneS2M (Bytes 4)) wbStorage' initContent wbIn = delayControls wbIn wbOut where romOut = case initContent of - Reloadable content-> bundle $ contentGenerator content + Reloadable content -> bundle $ contentGenerator content other -> deepErrorX $ "wbStorage': No content generator for " <> show other readData = ram readAddr writeEntry byteSelect @@ -191,16 +225,17 @@ wbStorage' initContent wbIn = delayControls wbIn wbOut Undefined -> (blockRamByteAddressableU, False) NonReloadable content -> - ( blockRamByteAddressable @_ @depth content, False) + (blockRamByteAddressable @_ @depth content, False) (readAddr, writeEntry, byteSelect, wbOut) = - unbundle (go <$> bundle (wbIn, readData, romOut)) + unbundle (go <$> bundle (wbIn, readData, romOut)) go (WishboneM2S{..}, readDataGo, (romWrite, romDone)) = ( wbAddr , writeEntryGo , byteSelectGo - , (emptyWishboneS2M @(Bytes 4)){acknowledge,readData = readDataGo,err}) + , (emptyWishboneS2M @(Bytes 4)){acknowledge, readData = readDataGo, err} + ) where (bitCoerce . resize -> wbAddr :: Index depth, alignment) = split @_ @(aw - 2) @2 addr addrLegal = addr < (natToNum @(4 * depth)) && alignment == 0 @@ -220,9 +255,9 @@ wbStorage' initContent wbIn = delayControls wbIn wbOut | isReloadable && not romDone = maxBound | otherwise = busSelect - -- | Delays the output controls to align them with the actual read / write timing. + -- \| Delays the output controls to align them with the actual read / write timing. delayControls :: - NFDataX a => + (NFDataX a) => Signal dom (WishboneM2S aw selWidth a) -> -- current M2S signal Signal dom (WishboneS2M a) -> Signal dom (WishboneS2M a) @@ -235,14 +270,18 @@ wbStorage' initContent wbIn = delayControls wbIn wbOut ack = (acknowledge <$> s2m0) .&&. (not <$> err1) .&&. (not <$> delayedAck) .&&. inCycle err1 = (err <$> s2m0) .&&. inCycle delayedAck = register False ack - s2m1 = (\wb newAck newErr-> wb{acknowledge = newAck, err = newErr}) - <$> s2m0 <*> delayedAck <*> err1 - --- | The double buffered Ram component is a memory component that contains two buffers --- and enables the user to write to one buffer and read from the other. 'AorB' --- selects which buffer is written to, while read operations read from the other buffer. + s2m1 = + (\wb newAck newErr -> wb{acknowledge = newAck, err = newErr}) + <$> s2m0 + <*> delayedAck + <*> err1 + +{- | The double buffered Ram component is a memory component that contains two buffers +and enables the user to write to one buffer and read from the other. 'AorB' +selects which buffer is written to, while read operations read from the other buffer. +-} doubleBufferedRam :: - forall dom memDepth a . + forall dom memDepth a. (HiddenClockResetEnable dom, KnownNat memDepth, 1 <= memDepth, Paddable a, ShowX a) => -- | Initial content. ContentType (2 * memDepth) a -> @@ -259,12 +298,13 @@ doubleBufferedRam initContent outputSelect rd0 wr0 = where (rd1, wr1) = unbundle $ updateAddrs <$> rd0 <*> wr0 <*> outputSelect --- | Version of 'doubleBufferedRam' with undefined initial contents. This component --- contains two buffers and enables the user to write to one buffer and read from the --- other. 'AorB' selects which buffer is written to, while read operations --- read from the other buffer. +{- | Version of 'doubleBufferedRam' with undefined initial contents. This component +contains two buffers and enables the user to write to one buffer and read from the +other. 'AorB' selects which buffer is written to, while read operations +read from the other buffer. +-} doubleBufferedRamU :: - forall dom memDepth a . + forall dom memDepth a. (HiddenClockResetEnable dom, KnownNat memDepth, 1 <= memDepth, NFDataX a) => -- | Controls which buffers is written to, while the other buffer is read from. Signal dom AorB -> @@ -281,14 +321,15 @@ doubleBufferedRamU outputSelect readAddr0 writeFrame0 = unbundle $ updateAddrs <$> readAddr0 <*> writeFrame0 <*> outputSelect rstFunc = clashCompileError "doubleBufferedRamU: reset function undefined" --- | The byte addressable double buffered Ram component is a memory component that --- consists of two buffers and internally stores its elements as a multiple of 8 bits. --- It contains a blockRam per byte and uses the one hot byte select signal to determine --- which bytes will be overwritten during a write operation. This components writes to --- one buffer and reads from the other. 'AorB' selects which buffer is --- written to, while read operations read from the other buffer. +{- | The byte addressable double buffered Ram component is a memory component that +consists of two buffers and internally stores its elements as a multiple of 8 bits. +It contains a blockRam per byte and uses the one hot byte select signal to determine +which bytes will be overwritten during a write operation. This components writes to +one buffer and reads from the other. 'AorB' selects which buffer is +written to, while read operations read from the other buffer. +-} doubleBufferedRamByteAddressable :: - forall dom memDepth a . + forall dom memDepth a. (HiddenClockResetEnable dom, KnownNat memDepth, 1 <= memDepth, Paddable a, ShowX a) => -- | Initial content ContentType (2 * memDepth) a -> @@ -307,22 +348,22 @@ doubleBufferedRamByteAddressable initContent outputSelect rd0 wr0 = where (rd1, wr1) = unbundle $ updateAddrs <$> rd0 <*> wr0 <*> outputSelect - --- | Version of 'doubleBufferedRamByteAddressable' where the initial content is undefined. --- This memory element consists of two buffers and internally stores its elements as a --- multiple of 8 bits. It contains a blockRam per byte and uses the one hot byte select --- signal to determine which nBytes will be overwritten during a write operation. --- This components writes to one buffer and reads from the other. Which buffer is --- used for reading while the other is used for writing is controlled by the 'AorB'. +{- | Version of 'doubleBufferedRamByteAddressable' where the initial content is undefined. +This memory element consists of two buffers and internally stores its elements as a +multiple of 8 bits. It contains a blockRam per byte and uses the one hot byte select +signal to determine which nBytes will be overwritten during a write operation. +This components writes to one buffer and reads from the other. Which buffer is +used for reading while the other is used for writing is controlled by the 'AorB'. +-} doubleBufferedRamByteAddressableU :: - forall dom memDepth a . - ( KnownNat memDepth, 1 <= memDepth, HiddenClockResetEnable dom, Paddable a, ShowX a) => + forall dom memDepth a. + (KnownNat memDepth, 1 <= memDepth, HiddenClockResetEnable dom, Paddable a, ShowX a) => -- | Controls which buffers is written to, while the other buffer is read from. Signal dom AorB -> -- | Read address. Signal dom (Index memDepth) -> -- | Incoming data frame. - Signal dom (Maybe (Located memDepth a)) -> + Signal dom (Maybe (Located memDepth a)) -> -- | One hot byte select for writing only Signal dom (ByteEnable a) -> -- | Outgoing data @@ -333,10 +374,11 @@ doubleBufferedRamByteAddressableU outputSelect readAddr0 writeFrame0 = (readAddr1, writeFrame1) = unbundle $ updateAddrs <$> readAddr0 <*> writeFrame0 <*> outputSelect --- | Blockram similar to 'blockRam' with the addition that it takes a byte select signal --- that controls which nBytes at the write address are updated. +{- | Blockram similar to 'blockRam' with the addition that it takes a byte select signal +that controls which nBytes at the write address are updated. +-} blockRamByteAddressable :: - forall dom memDepth a . + forall dom memDepth a. (HiddenClockResetEnable dom, KnownNat memDepth, 1 <= memDepth, Paddable a, ShowX a) => -- | Initial content. ContentType memDepth a -> @@ -350,25 +392,27 @@ blockRamByteAddressable :: Signal dom a blockRamByteAddressable initContent readAddr newEntry byteSelect = getDataBe @8 . RegisterBank <$> case initContent of - Blob _ -> clashCompileError "blockRamByteAddressable: Singular MemBlobs are not supported. " + Blob _ -> clashCompileError "blockRamByteAddressable: Singular MemBlobs are not supported. " Vec vecOfA -> go (byteRam . Vec <$> transpose (fmap getBytes vecOfA)) BlobVec blobs -> go (fmap (byteRam . Blob) blobs) - File _ -> clashCompileError "blockRamByteAddressable: Singular source files for initial content are not supported. " + File _ -> + clashCompileError + "blockRamByteAddressable: Singular source files for initial content are not supported. " FileVec blobs -> go (fmap (byteRam . File) blobs) where - go brams = readBytes + go brams = readBytes where writeBytes = unbundle $ splitWriteInBytes <$> newEntry <*> byteSelect readBytes = bundle $ brams <*> writeBytes getBytes (getRegsBe -> RegisterBank (vec :: Vec (Regs a 8) Byte)) = vec byteRam = (`initializedRam` readAddr) - --- | Version of 'blockRamByteAddressable' with undefined initial contents. It is similar --- to 'blockRam' with the addition that it takes a byte select signal that controls --- which nBytes at the write address are updated. +{- | Version of 'blockRamByteAddressable' with undefined initial contents. It is similar +to 'blockRam' with the addition that it takes a byte select signal that controls +which nBytes at the write address are updated. +-} blockRamByteAddressableU :: - forall dom memDepth a . + forall dom memDepth a. (HiddenClockResetEnable dom, KnownNat memDepth, 1 <= memDepth, Paddable a, ShowX a) => -- | Read address. Signal dom (Index memDepth) -> @@ -387,15 +431,22 @@ blockRamByteAddressableU readAddr newEntry byteSelect = rstFunc = clashCompileError "blockRamByteAddressableU: reset function undefined" data RegisterWritePriority = CircuitPriority | WishbonePriority - deriving Eq + deriving (Eq) --- | Register with additional wishbone interface, this component has a configurable --- priority that determines which value gets stored in the register during a write conflict. --- The `RegisterWritePriority` determines if the wishbone write gets accepted or if the --- `Df` write gets accepted. The other value is discarded. +{- | Register with additional wishbone interface, this component has a configurable +priority that determines which value gets stored in the register during a write conflict. +The `RegisterWritePriority` determines if the wishbone write gets accepted or if the +`Df` write gets accepted. The other value is discarded. +-} registerWbC :: - forall dom a nBytes aw . - (HiddenClockResetEnable dom, Paddable a, KnownNat nBytes, 1 <= nBytes, KnownNat aw, 2 <= aw) => + forall dom a nBytes aw. + ( HiddenClockResetEnable dom + , Paddable a + , KnownNat nBytes + , 1 <= nBytes + , KnownNat aw + , 2 <= aw + ) => -- | Determines the write priority on write collisions RegisterWritePriority -> -- | Initial value. @@ -411,20 +462,22 @@ registerWbC prio initVal = case cancelMulDiv @nBytes @8 of | prio == WishbonePriority = (\WishboneM2S{..} -> not (strobe && busCycle)) <$> wbM2S | otherwise = pure True --- | Register with additional wishbone interface, this component has a configurable --- priority that determines which value gets stored in the register during a write conflict. --- With 'CircuitPriority', the incoming value in the fourth argument gets stored on a --- collision and the wishbone bus gets acknowledged, but the value is silently ignored. --- With 'WishbonePriority', the incoming wishbone write gets accepted and the value in the --- fourth argument gets ignored. +{- | Register with additional wishbone interface, this component has a configurable +priority that determines which value gets stored in the register during a write conflict. +With 'CircuitPriority', the incoming value in the fourth argument gets stored on a +collision and the wishbone bus gets acknowledged, but the value is silently ignored. +With 'WishbonePriority', the incoming wishbone write gets accepted and the value in the +fourth argument gets ignored. +-} registerWb :: - forall dom a nBytes addrW . + forall dom a nBytes addrW. ( HiddenClockResetEnable dom , Paddable a , KnownNat nBytes , 1 <= nBytes , KnownNat addrW - , 2 <= addrW) => + , 2 <= addrW + ) => -- | Determines the write priority on write collisions RegisterWritePriority -> -- | Initial value. @@ -441,21 +494,24 @@ registerWb writePriority initVal wbIn sigIn = registerWbE writePriority initVal wbIn sigIn (pure maxBound) {-# NOINLINE registerWbE #-} --- | Register with additional wishbone interface, this component has a configurable --- priority that determines which value gets stored in the register during a write conflict. --- With 'CircuitPriority', the incoming value in the fourth argument gets stored on a --- collision and the wishbone bus gets acknowledged, but the value is silently ignored. --- With 'WishbonePriority', the incoming wishbone write gets accepted and the value in the --- fourth argument gets ignored. This version has an additional argument for circuit write --- byte enables. + +{- | Register with additional wishbone interface, this component has a configurable +priority that determines which value gets stored in the register during a write conflict. +With 'CircuitPriority', the incoming value in the fourth argument gets stored on a +collision and the wishbone bus gets acknowledged, but the value is silently ignored. +With 'WishbonePriority', the incoming wishbone write gets accepted and the value in the +fourth argument gets ignored. This version has an additional argument for circuit write +byte enables. +-} registerWbE :: - forall dom a nBytes addrW . + forall dom a nBytes addrW. ( HiddenClockResetEnable dom , Paddable a , KnownNat nBytes , 1 <= nBytes , KnownNat addrW - , 2 <= addrW) => + , 2 <= addrW + ) => -- | Determines the write priority on write collisions RegisterWritePriority -> -- | Initial value. @@ -475,15 +531,16 @@ registerWbE writePriority initVal wbIn sigIn sigByteEnables = (regOut, wbOut) regOut = registerByteAddressable initVal regIn byteEnables (byteEnables, wbOut, regIn) = unbundle (go <$> regOut <*> sigIn <*> sigByteEnables <*> wbIn) go :: - a -> + a -> Maybe a -> BitVector (Regs a 8) -> WishboneM2S addrW nBytes (Bytes nBytes) -> (BitVector (Regs a 8), WishboneS2M (Bytes nBytes), a) go regOut0 sigIn0 sigbyteEnables0 WishboneM2S{..} = ( byteEnables0 - , (emptyWishboneS2M @(Bytes nBytes)) {acknowledge, err, readData} - , regIn0 ) + , (emptyWishboneS2M @(Bytes nBytes)){acknowledge, err, readData} + , regIn0 + ) where (alignedAddress, alignment) = split @_ @(addrW - 2) @2 addr addressRange = maxBound :: Index (Max 1 (Regs a (nBytes * 8))) @@ -497,20 +554,21 @@ registerWbE writePriority initVal wbIn sigIn sigByteEnables = (regOut, wbOut) RegisterBank vec -> vec !! wbAddr wbByteEnables = - resize . pack . reverse $ replace wbAddr busSelect (repeat @(Regs a (nBytes*8)) 0) + resize . pack . reverse $ replace wbAddr busSelect (repeat @(Regs a (nBytes * 8)) 0) sigRegIn = fromMaybe (errorX "registerWb: sigIn is Nothing when Just is expected.") sigIn0 wbRegIn = getDataLe . RegisterBank $ repeat writeData (byteEnables0, regIn0) = case (writePriority, isJust sigIn0, wbWriting) of - (CircuitPriority , True , _) -> (sigbyteEnables0, sigRegIn) - (CircuitPriority , False, True) -> (wbByteEnables, wbRegIn) - (WishbonePriority, _ , True) -> (wbByteEnables, wbRegIn) - (WishbonePriority, True , False) -> (sigbyteEnables0, sigRegIn) - (_ , False, False) -> (0, errorX "registerWb: register input not defined.") - --- | Register similar to 'register' with the addition that it takes a byte select signal --- that controls which nBytes are updated. + (CircuitPriority, True, _) -> (sigbyteEnables0, sigRegIn) + (CircuitPriority, False, True) -> (wbByteEnables, wbRegIn) + (WishbonePriority, _, True) -> (wbByteEnables, wbRegIn) + (WishbonePriority, True, False) -> (sigbyteEnables0, sigRegIn) + (_, False, False) -> (0, errorX "registerWb: register input not defined.") + +{- | Register similar to 'register' with the addition that it takes a byte select signal +that controls which nBytes are updated. +-} registerByteAddressable :: - forall dom a . + forall dom a. (HiddenClockResetEnable dom, Paddable a) => -- | Initial value. a -> @@ -525,15 +583,19 @@ registerByteAddressable initVal newVal byteEnables = where initBytes = getBytes initVal newBytes = unbundle $ getBytes <$> newVal - regsOut = (`andEnable` register) <$> - unbundle (reverse . unpack <$> byteEnables) <*> initBytes <*> newBytes + regsOut = + (`andEnable` register) + <$> unbundle (reverse . unpack <$> byteEnables) + <*> initBytes + <*> newBytes getBytes (getRegsLe -> RegisterBank vec) = vec --- | Takes singular write operation (Maybe (Index maxIndex, writeData)) and splits it up --- according to a supplied byteselect bitvector into a vector of byte sized write operations --- (Maybe (Index maxIndex, Byte)). +{- | Takes singular write operation (Maybe (Index maxIndex, writeData)) and splits it up +according to a supplied byteselect bitvector into a vector of byte sized write operations +(Maybe (Index maxIndex, Byte)). +-} splitWriteInBytes :: - forall maxIndex writeData . + forall maxIndex writeData. (Paddable writeData) => -- | Incoming write operation. Maybe (Located maxIndex writeData) -> @@ -544,25 +606,24 @@ splitWriteInBytes :: splitWriteInBytes (Just (addr, writeData)) byteSelect = case getRegsBe writeData of RegisterBank vec -> orNothing <$> unpack byteSelect <*> fmap (addr,) vec - splitWriteInBytes Nothing _ = repeat Nothing --- | Takes an address and write operation and 'bitCoerce's the addresses as follows: --- 'bitCoerce' (address, bool) +{- | Takes an address and write operation and 'bitCoerce's the addresses as follows: +'bitCoerce' (address, bool) +-} updateAddrs :: (KnownNat n, 1 <= n, KnownNat m, 1 <= m) => -- | An address. - Index n + Index n -> -- | A write operation. - -> Maybe (Index m, b) + Maybe (Index m, b) -> -- | A boolean that will be used for the addresses LSBs. - -> AorB + AorB -> -- | -- 1. Updated address -- 2. Write operation with updated address. - -> (Index (n * 2), Maybe (Index (m * 2), b)) + (Index (n * 2), Maybe (Index (m * 2), b)) updateAddrs rdAddr (Just (i, a)) bufSelect = (mul2Index rdAddr bufSelect, Just (mul2Index i (swapAorB bufSelect), a)) - updateAddrs rdAddr Nothing bufSelect = (mul2Index rdAddr bufSelect, Nothing) diff --git a/bittide/src/Bittide/ElasticBuffer.hs b/bittide/src/Bittide/ElasticBuffer.hs index d32486278..5169b5d05 100644 --- a/bittide/src/Bittide/ElasticBuffer.hs +++ b/bittide/src/Bittide/ElasticBuffer.hs @@ -5,37 +5,38 @@ module Bittide.ElasticBuffer where -import Clash.Prelude import Clash.Cores.Xilinx.DcFifo +import Clash.Prelude import GHC.Stack import Bittide.ClockControl (RelDataCount, targetDataCount) -import qualified Clash.Explicit.Prelude as E import qualified Clash.Cores.Extra as CE +import qualified Clash.Explicit.Prelude as E data EbMode - -- | Disable write, enable read - = Drain - -- | Enable write, disable read - | Fill - -- | Enable write, enable read - | Pass - deriving (Generic, NFDataX, Eq, Show) + = -- | Disable write, enable read + Drain + | -- | Enable write, disable read + Fill + | -- | Enable write, enable read + Pass + deriving (Generic, NFDataX, Eq, Show) type Underflow = Bool type Overflow = Bool ebModeToReadWrite :: EbMode -> (Bool, Bool) ebModeToReadWrite = \case - Fill -> (False, True) + Fill -> (False, True) Drain -> (True, False) - Pass -> (True, True) + Pass -> (True, True) {-# NOINLINE sticky #-} + -- | Create a sticky version of a boolean signal. sticky :: - KnownDomain dom => + (KnownDomain dom) => Clock dom -> Reset dom -> Signal dom Bool -> @@ -45,8 +46,10 @@ sticky clk rst a = stickyA stickyA = E.register clk rst enableGen False (stickyA .||. a) {-# NOINLINE xilinxElasticBuffer #-} --- | An elastic buffer backed by a Xilinx FIFO. It exposes all its control and --- monitor signals in its read domain. + +{- | An elastic buffer backed by a Xilinx FIFO. It exposes all its control and +monitor signals in its read domain. +-} xilinxElasticBuffer :: forall n readDom writeDom a. ( HasCallStack @@ -54,7 +57,8 @@ xilinxElasticBuffer :: , KnownDomain writeDom , NFDataX a , KnownNat n - , 4 <= n, n <= 17 + , 4 <= n + , n <= 17 ) => Clock readDom -> Clock writeDom -> @@ -64,9 +68,9 @@ xilinxElasticBuffer :: Signal readDom EbMode -> Signal writeDom a -> ( Signal readDom (RelDataCount n) - -- Indicates whether the FIFO under or overflowed. This signal is sticky: it - -- will only deassert upon reset. - , Signal readDom Underflow + , -- Indicates whether the FIFO under or overflowed. This signal is sticky: it + -- will only deassert upon reset. + Signal readDom Underflow , Signal writeDom Overflow , Signal readDom a ) @@ -76,7 +80,9 @@ xilinxElasticBuffer clkRead clkWrite rstRead ebMode wdata = -- 'Unsigned' with 'targetDataCount' equals 'shiftR maxBound 1 + 1'. -- This way, the representation can be easily switched without -- introducing major code changes. - (+ targetDataCount) . bitCoerce . (+ (-1 - shiftR maxBound 1)) + (+ targetDataCount) + . bitCoerce + . (+ (-1 - shiftR maxBound 1)) <$> readCount , isUnderflowSticky , isOverflowSticky @@ -87,10 +93,15 @@ xilinxElasticBuffer clkRead clkWrite rstRead ebMode wdata = rstWriteBool = CE.safeDffSynchronizer clkRead clkWrite False (unsafeToActiveHigh rstRead) - FifoOut{readCount, isUnderflow, isOverflow, fifoData} = dcFifo - (defConfig @n){dcOverflow=True, dcUnderflow=True} - clkWrite noResetWrite clkRead noResetRead - writeData readEnable + FifoOut{readCount, isUnderflow, isOverflow, fifoData} = + dcFifo + (defConfig @n){dcOverflow = True, dcUnderflow = True} + clkWrite + noResetWrite + clkRead + noResetRead + writeData + readEnable -- We make sure to "stickify" the signals in their original domain. The -- synchronizer might lose samples depending on clock configurations. @@ -108,7 +119,6 @@ xilinxElasticBuffer clkRead clkWrite rstRead ebMode wdata = writeData = mux writeEnableSynced (Just <$> wdata) (pure Nothing) - {-# NOINLINE resettableXilinxElasticBuffer #-} resettableXilinxElasticBuffer :: forall n readDom writeDom a. @@ -116,7 +126,9 @@ resettableXilinxElasticBuffer :: , KnownDomain readDom , NFDataX a , KnownNat n - , 4 <= n, n <= 17) => + , 4 <= n + , n <= 17 + ) => Clock readDom -> Clock writeDom -> -- | Resetting resets the 'Underflow' and 'Overflow' signals, but not the 'RelDataCount' @@ -139,9 +151,10 @@ resettableXilinxElasticBuffer clkRead clkWrite rstRead wdata = controllerReset = unsafeFromActiveHigh (unsafeToActiveHigh rstRead .||. under .||. over1) - (ebMode, stable) = unbundle $ - withClockResetEnable clkRead controllerReset enableGen $ - mealy goControl Drain dataCount + (ebMode, stable) = + unbundle + $ withClockResetEnable clkRead controllerReset enableGen + $ mealy goControl Drain dataCount goControl :: EbMode -> RelDataCount n -> (EbMode, (EbMode, Bool)) goControl state0 datacount = (state1, (state0, stable0)) diff --git a/bittide/src/Bittide/Ethernet/Mac.hs b/bittide/src/Bittide/Ethernet/Mac.hs index 9b4db5d44..b5b504816 100644 --- a/bittide/src/Bittide/Ethernet/Mac.hs +++ b/bittide/src/Bittide/Ethernet/Mac.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PostfixOperators #-} {-# LANGUAGE RecordWildCards #-} + module Bittide.Ethernet.Mac where import Clash.Explicit.Prelude hiding ((:<)) @@ -14,7 +15,7 @@ import Bittide.Wishbone import Clash.Annotations.Primitive import Clash.Cores.Xilinx.Ethernet.Gmii.Internal import Data.Constraint.Nat.Extra -import Data.List.Infinite (Infinite((:<)), (...)) +import Data.List.Infinite (Infinite ((:<)), (...)) import Data.Maybe import Data.String.Interpolate (__i) import Protocols.Axi4.Stream @@ -30,22 +31,25 @@ data EthMacStatus = EthMacStatus , txFifoGoodFrame :: "txFifoGoodFrame" ::: Bool , rxBadFrame :: "rxBadFrame" ::: Bool , rxBadFcs :: "rxBadFcs" ::: Bool - , rxFifoOverflow :: "rxFifoOverflow" :::Bool + , rxFifoOverflow :: "rxFifoOverflow" ::: Bool , rxFifoBadFrame :: "rxFifoBadFrame" ::: Bool , rxFifoGoodFrame :: "rxFifoGoodFrame" ::: Bool - } deriving (Generic, NFDataX, BitPack) + } + deriving (Generic, NFDataX, BitPack) --- | Wishbone peripheral that keeps track of the status flags of the Ethernet MAC. --- Every cycle that a flag is set, will be counted with a counter. The width of the counters --- is configurable using the first `SNat counterWidth` argument. +{- | Wishbone peripheral that keeps track of the status flags of the Ethernet MAC. +Every cycle that a flag is set, will be counted with a counter. The width of the counters +is configurable using the first `SNat counterWidth` argument. +-} macStatusInterfaceWb :: - forall dom aw nBytes counterWidth . + forall dom aw nBytes counterWidth. ( CP.HiddenClockResetEnable dom , KnownNat nBytes , KnownNat aw , 2 <= aw , 1 <= nBytes - , counterWidth <= nBytes * 8) => + , counterWidth <= nBytes * 8 + ) => -- | Number of bits of the counters SNat counterWidth -> Circuit @@ -71,11 +75,13 @@ ethMac1GFifoC :: , KnownDomain rx ) => -- Configuration + -- | TX FIFO depth SNat txFifoDepth -> -- | RX FIFO depth SNat rxFifoDepth -> -- Clocks and resets + -- | Logic clock Clock sys -> -- | Logic reset @@ -97,14 +103,37 @@ ethMac1GFifoC :: Circuit (Axi4Stream sys ('Axi4StreamConfig 1 0 0) Bool, CSignal rx Gmii) (Axi4Stream sys ('Axi4StreamConfig 1 0 0) Bool, CSignal tx Gmii, CSignal sys EthMacStatus) -ethMac1GFifoC txFifoDepth rxFifoDepth sysClk sysRst txClk txRst rxClk rxRst miiSel txClkEna +ethMac1GFifoC + txFifoDepth + rxFifoDepth + sysClk + sysRst + txClk + txRst + rxClk + rxRst + miiSel + txClkEna rxClkEna = Circuit go - where - go ((axiTxM2S, gmiiRx), (axiRxS2M, _, _)) = ((axiTxS2M, pure ()), (axiRxM2S, gmiiTx, ethStatus)) where - (axiTxS2M, axiRxM2S, gmiiTx, ethStatus) = - ethMac1GFifo txFifoDepth rxFifoDepth sysClk sysRst txClk txRst rxClk rxRst miiSel - txClkEna rxClkEna axiTxM2S gmiiRx axiRxS2M + go ((axiTxM2S, gmiiRx), (axiRxS2M, _, _)) = ((axiTxS2M, pure ()), (axiRxM2S, gmiiTx, ethStatus)) + where + (axiTxS2M, axiRxM2S, gmiiTx, ethStatus) = + ethMac1GFifo + txFifoDepth + rxFifoDepth + sysClk + sysRst + txClk + txRst + rxClk + rxRst + miiSel + txClkEna + rxClkEna + axiTxM2S + gmiiRx + axiRxS2M ethMac1GFifo :: ( KnownDomain sys @@ -112,11 +141,13 @@ ethMac1GFifo :: , KnownDomain rx ) => -- Configuration + -- | TX FIFO depth SNat txFifoDepth -> -- | RX FIFO depth SNat rxFifoDepth -> -- Clocks and resets + -- | Logic clock Clock sys -> -- | Logic reset @@ -143,63 +174,132 @@ ethMac1GFifo :: Signal sys Axi4StreamS2M -> ( -- TX Axi outputs Signal sys Axi4StreamS2M - -- RX Axi outputs - , Signal sys (Maybe (Axi4StreamM2S ('Axi4StreamConfig 1 0 0) Bool)) - -- GMII outputs - , Signal tx Gmii - -- TX Status - , Signal sys EthMacStatus + , -- RX Axi outputs + Signal sys (Maybe (Axi4StreamM2S ('Axi4StreamConfig 1 0 0) Bool)) + , -- GMII outputs + Signal tx Gmii + , -- TX Status + Signal sys EthMacStatus ) +ethMac1GFifo + txFifoDepth + rxFifoDepth + sysClk + sysRst + txClk + txRst + rxClk + rxRst + miiSel + txClkEna + rxClkEna + txAxiM2S + rxGmii + rxAxiS2M = + (txAxiS2M, rxAxiM2S, gmiiTx, ethStatus) + where + txAxiS2M = Axi4StreamS2M <$> txAxiReady -ethMac1GFifo txFifoDepth rxFifoDepth sysClk sysRst txClk txRst rxClk rxRst miiSel txClkEna - rxClkEna txAxiM2S rxGmii rxAxiS2M - = (txAxiS2M, rxAxiM2S, gmiiTx, ethStatus) - where - txAxiS2M = Axi4StreamS2M <$> txAxiReady - - txAxiData = _tdata . fromJust <$> txAxiM2S - txAxiKeep = _tkeep . fromJust <$> txAxiM2S - txAxiValid = isJust <$> txAxiM2S - txAxiLast = _tlast . fromJust <$> txAxiM2S - txAxiUser = _tuser . fromJust <$> txAxiM2S + txAxiData = _tdata . fromJust <$> txAxiM2S + txAxiKeep = _tkeep . fromJust <$> txAxiM2S + txAxiValid = isJust <$> txAxiM2S + txAxiLast = _tlast . fromJust <$> txAxiM2S + txAxiUser = _tuser . fromJust <$> txAxiM2S - rxAxiReady = _tready <$> rxAxiS2M - gmiiRxData' = bitCoerce . gmiiData <$> rxGmii - gmiiRxValid' = bitCoerce . gmiiValid <$> rxGmii - gmiiRxError' = bitCoerce . gmiiError <$> rxGmii + rxAxiReady = _tready <$> rxAxiS2M + gmiiRxData' = bitCoerce . gmiiData <$> rxGmii + gmiiRxValid' = bitCoerce . gmiiValid <$> rxGmii + gmiiRxError' = bitCoerce . gmiiError <$> rxGmii - -- Instantiate the blackbox - gmiiTx = Gmii <$> gmiiTxData' <*> fmap bitCoerce gmiiTxEnable' <*> fmap bitCoerce gmiiTxError' - ( txAxiReady, rxAxiData, rxAxiKeep, rxAxiValid, rxAxiLast, rxAxiUser, gmiiTxData' - , gmiiTxEnable', gmiiTxError', txFifoUnderflow, txFifoOverflow, txFifoBadFrame - , txFifoGoodFrame, rxBadFrame, rxBadFcs, rxFifoOverflow, rxFifoBadFrame - , rxFifoGoodFrame - ) = - ethMac1GFifoBb txFifoDepth rxFifoDepth sysClk sysRst txClk txRst rxClk rxRst - miiSel txClkEna rxClkEna txAxiData txAxiKeep txAxiValid txAxiLast txAxiUser - gmiiRxData' gmiiRxValid' gmiiRxError' rxAxiReady + -- Instantiate the blackbox + gmiiTx = Gmii <$> gmiiTxData' <*> fmap bitCoerce gmiiTxEnable' <*> fmap bitCoerce gmiiTxError' + ( txAxiReady + , rxAxiData + , rxAxiKeep + , rxAxiValid + , rxAxiLast + , rxAxiUser + , gmiiTxData' + , gmiiTxEnable' + , gmiiTxError' + , txFifoUnderflow + , txFifoOverflow + , txFifoBadFrame + , txFifoGoodFrame + , rxBadFrame + , rxBadFcs + , rxFifoOverflow + , rxFifoBadFrame + , rxFifoGoodFrame + ) = + ethMac1GFifoBb + txFifoDepth + rxFifoDepth + sysClk + sysRst + txClk + txRst + rxClk + rxRst + miiSel + txClkEna + rxClkEna + txAxiData + txAxiKeep + txAxiValid + txAxiLast + txAxiUser + gmiiRxData' + gmiiRxValid' + gmiiRxError' + rxAxiReady - ethStatus = makeEthStatus <$> txFifoUnderflow <*> txFifoOverflow <*> txFifoBadFrame - <*> txFifoGoodFrame <*> rxBadFrame <*> rxBadFcs <*> rxFifoOverflow <*> rxFifoBadFrame - <*> rxFifoGoodFrame + ethStatus = + makeEthStatus + <$> txFifoUnderflow + <*> txFifoOverflow + <*> txFifoBadFrame + <*> txFifoGoodFrame + <*> rxBadFrame + <*> rxBadFcs + <*> rxFifoOverflow + <*> rxFifoBadFrame + <*> rxFifoGoodFrame - rxAxiM2S = makeAxi <$> rxAxiValid <*> rxAxiData <*> rxAxiKeep <*> rxAxiUser <*> rxAxiLast + rxAxiM2S = makeAxi <$> rxAxiValid <*> rxAxiData <*> rxAxiKeep <*> rxAxiUser <*> rxAxiLast --- | Utility function to create an Axi4StreamM2S from it's components. --- Exists to explicitly show the order of the arguments closely to the code that uses it. -makeAxi :: KnownNat n => Bool -> Vec n (Unsigned 8) -> Vec n Bool -> Bool -> Bool -> +{- | Utility function to create an Axi4StreamM2S from it's components. +Exists to explicitly show the order of the arguments closely to the code that uses it. +-} +makeAxi :: + (KnownNat n) => + Bool -> + Vec n (Unsigned 8) -> + Vec n Bool -> + Bool -> + Bool -> Maybe (Axi4StreamM2S ('Axi4StreamConfig n 0 0) Bool) makeAxi _tvalid _tdata _tkeep _tuser _tlast = orNothing _tvalid Axi4StreamM2S{..} - where - _tid = 0 - _tdest = 0 - _tstrb = repeat True + where + _tid = 0 + _tdest = 0 + _tstrb = repeat True --- | Utility function to create the EthMacStatus from it's components. --- Exists to explicitly show the order of the arguments closely to the code that uses it. -makeEthStatus :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> EthMacStatus -makeEthStatus txFifoUnderflow txFifoOverflow txFifoBadFrame txFifoGoodFrame rxBadFrame - rxBadFcs rxFifoOverflow rxFifoBadFrame rxFifoGoodFrame = EthMacStatus{..} +{- | Utility function to create the EthMacStatus from it's components. +Exists to explicitly show the order of the arguments closely to the code that uses it. +-} +makeEthStatus :: + Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> EthMacStatus +makeEthStatus + txFifoUnderflow + txFifoOverflow + txFifoBadFrame + txFifoGoodFrame + rxBadFrame + rxBadFcs + rxFifoOverflow + rxFifoBadFrame + rxFifoGoodFrame = EthMacStatus{..} -- | 1G Ethernet MAC with TX and RX FIFOs ethMac1GFifoBb :: @@ -208,11 +308,13 @@ ethMac1GFifoBb :: , KnownDomain rx ) => -- Configuration + -- | TX FIFO depth SNat txFifoDepth -> -- | RX FIFO depth SNat rxFifoDepth -> -- Clocks and resets + -- | Logic clock Clock sys -> -- | Logic reset @@ -231,8 +333,8 @@ ethMac1GFifoBb :: Signal tx Bool -> -- | RX Clock enable Signal rx Bool -> - -- TX Axi inputs + -- | TX Axi data Signal sys (Vec 1 (Unsigned 8)) -> -- | TX Axi keep @@ -243,120 +345,118 @@ ethMac1GFifoBb :: Signal sys Bool -> -- | TX Axi user Signal sys Bool -> - -- RX Gmii inputs + -- | RX Gmii data Signal rx (BitVector 8) -> -- | RX Gmii valid Signal rx Bool -> -- | RX Gmii error Signal rx Bool -> - -- RX Axi inputs + -- | RX Axi ready Signal sys Bool -> - ( - -- TX Axi outputs - -- | TX Axi ready - Signal sys Bool, - - -- RX Axi outputs - -- | RX Axi data - Signal sys (Vec 1 (Unsigned 8)), - -- | RX Axi keep - Signal sys (Vec 1 Bool), - -- | RX Axi valid - Signal sys Bool, - -- | RX Axi last - Signal sys Bool, - -- | RX Axi user - Signal sys Bool, - - -- GMII outputs - -- | GMII TX data - Signal tx (BitVector 8), - -- | GMII TX enable - Signal tx Bool, - -- | GMII TX error - Signal tx Bool, - - -- TX Status - -- | TX FIFO underflow - Signal sys Bool, - -- | TX FIFO overflow - Signal sys Bool, - -- | TX FIFO bad frame - Signal sys Bool, - -- | TX FIFO good frame - Signal sys Bool, - - -- RX Status - -- | RX error bad frame - Signal sys Bool, - -- | RX error bad FCS - Signal sys Bool, - -- | RX FIFO overflow - Signal sys Bool, - -- | RX FIFO bad frame - Signal sys Bool, - -- | RX FIFO good frame + ( -- TX Axi outputs + -- \| TX Axi ready + Signal sys Bool + , -- RX Axi outputs + -- \| RX Axi data + Signal sys (Vec 1 (Unsigned 8)) + , -- \| RX Axi keep + Signal sys (Vec 1 Bool) + , -- \| RX Axi valid + Signal sys Bool + , -- \| RX Axi last + Signal sys Bool + , -- \| RX Axi user + Signal sys Bool + , -- GMII outputs + -- \| GMII TX data + Signal tx (BitVector 8) + , -- \| GMII TX enable + Signal tx Bool + , -- \| GMII TX error + Signal tx Bool + , -- TX Status + -- \| TX FIFO underflow + Signal sys Bool + , -- \| TX FIFO overflow + Signal sys Bool + , -- \| TX FIFO bad frame + Signal sys Bool + , -- \| TX FIFO good frame + Signal sys Bool + , -- RX Status + -- \| RX error bad frame + Signal sys Bool + , -- \| RX error bad FCS + Signal sys Bool + , -- \| RX FIFO overflow + Signal sys Bool + , -- \| RX FIFO bad frame + Signal sys Bool + , -- \| RX FIFO good frame Signal sys Bool ) ethMac1GFifoBb SNat SNat !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ = (err, err, err, err, err, err, err, err, err, err, err, err, err, err, err, err, err, err) where - err :: forall dom a . NFDataX a => Signal dom a + err :: forall dom a. (NFDataX a) => Signal dom a err = pure $ deepErrorX "simulation model not implemented" - {-# NOINLINE ethMac1GFifoBb #-} {-# ANN ethMac1GFifoBb hasBlackBox #-} -{-# ANN ethMac1GFifoBb ( - let - ( _sys - :< _tx - :< _rx - :< txFifoDepth - :< rxFifoDepth - :< sysClk - :< sysRst - :< txClk - :< txRst - :< rxClk - :< rxRst - :< miiSel - :< txClkEna - :< rxClkEna - :< txAxiData - :< txAxiKeep - :< txAxiValid - :< txAxiLast - :< txAxiUser - :< gmiiRxData - :< gmiiRxValid - :< gmiiRxError - :< rxAxiReady - :< txAxiReady - :< rxAxiData - :< rxAxiKeep - :< rxAxiValid - :< rxAxiLast - :< rxAxiUser - :< gmiiTxData - :< gmiiTxEn - :< gmiiTxErr - :< txFifoUnderflow - :< txFifoOverflow - :< txFifoBadFrame - :< txFifoGoodFrame - :< rxBadFrame - :< rxBadFcs - :< rxFifoOverflow - :< rxFifoBadFrame - :< rxFifoGoodFrame - :< _ ) = ((0::Int)...) - funcName = 'ethMac1GFifoBb - in - InlineYamlPrimitive [Verilog] [__i| +{-# ANN + ethMac1GFifoBb + ( let + ( _sys + :< _tx + :< _rx + :< txFifoDepth + :< rxFifoDepth + :< sysClk + :< sysRst + :< txClk + :< txRst + :< rxClk + :< rxRst + :< miiSel + :< txClkEna + :< rxClkEna + :< txAxiData + :< txAxiKeep + :< txAxiValid + :< txAxiLast + :< txAxiUser + :< gmiiRxData + :< gmiiRxValid + :< gmiiRxError + :< rxAxiReady + :< txAxiReady + :< rxAxiData + :< rxAxiKeep + :< rxAxiValid + :< rxAxiLast + :< rxAxiUser + :< gmiiTxData + :< gmiiTxEn + :< gmiiTxErr + :< txFifoUnderflow + :< txFifoOverflow + :< txFifoBadFrame + :< txFifoGoodFrame + :< rxBadFrame + :< rxBadFcs + :< rxFifoOverflow + :< rxFifoBadFrame + :< rxFifoGoodFrame + :< _ + ) = ((0 :: Int) ...) + funcName = 'ethMac1GFifoBb + in + InlineYamlPrimitive + [Verilog] + [__i| BlackBox: kind: Declaration name: #{funcName} @@ -448,4 +548,5 @@ ethMac1GFifoBb SNat SNat !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ !_ = .cfg_rx_enable(1'b1) ); |] - ) #-} + ) + #-} diff --git a/bittide/src/Bittide/Link.hs b/bittide/src/Bittide/Link.hs index c8e24eab7..009cdd876 100644 --- a/bittide/src/Bittide/Link.hs +++ b/bittide/src/Bittide/Link.hs @@ -1,21 +1,20 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - -{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} --- | A unidirectional communication primitive that moves a fixed-rate stream of frames --- between a pair of nodes. The frame size can be unique for each link including the possibility --- of single bit frames. The links and infrastructure perform zero in-band signaling. --- A link starts with a 'gatherUnit' and 'txUnit' and is terminated by a 'rxUnit' and --- 'scatterUnit'. A 'Bittide.Switch' contains single depth versions of the 'gatherUnit' --- and 'scatterUnit' that essentially reduce to a single 'register'. +{- | A unidirectional communication primitive that moves a fixed-rate stream of frames +between a pair of nodes. The frame size can be unique for each link including the possibility +of single bit frames. The links and infrastructure perform zero in-band signaling. +A link starts with a 'gatherUnit' and 'txUnit' and is terminated by a 'rxUnit' and +'scatterUnit'. A 'Bittide.Switch' contains single depth versions of the 'gatherUnit' +and 'scatterUnit' that essentially reduce to a single 'register'. +-} module Bittide.Link where import Clash.Prelude @@ -32,21 +31,23 @@ import Bittide.SharedTypes -- Internal states of the txUnit. data TransmissionState preambleWidth seqCountWidth frameWidth - = LinkThrough - -- ^ The txUnit is transparent, the incoming frame is directly routed to the output. - | TransmitPreamble (Index (Regs (BitVector preambleWidth) frameWidth)) - -- ^ The txUnit is transmitting the preamble, the index keeps track of which frame of - -- the preamble is being transmitted. - | TransmitSeqCounter (Index (DivRU seqCountWidth frameWidth)) - -- ^ The txUnit is transmitting the stored sequence counter, the index keeps track - -- of which frame of the sequence counter is being transmitted. - deriving (Generic, NFDataX) + = -- | The txUnit is transparent, the incoming frame is directly routed to the output. + LinkThrough + | -- | The txUnit is transmitting the preamble, the index keeps track of which frame of + -- the preamble is being transmitted. + TransmitPreamble (Index (Regs (BitVector preambleWidth) frameWidth)) + | -- | The txUnit is transmitting the stored sequence counter, the index keeps track + -- of which frame of the sequence counter is being transmitted. + TransmitSeqCounter (Index (DivRU seqCountWidth frameWidth)) + deriving (Generic, NFDataX) {-# NOINLINE txUnit #-} --- | Transmitter for the Bittide Link, it either transmits the incoming gather frame or --- transmits the preamble followed by the sequence counter. + +{- | Transmitter for the Bittide Link, it either transmits the incoming gather frame or +transmits the preamble followed by the sequence counter. +-} txUnit :: - forall core nBytes aw preambleWidth frameWidth seqCountWidth . + forall core nBytes aw preambleWidth frameWidth seqCountWidth. ( HiddenClockResetEnable core , KnownNat preambleWidth , KnownNat seqCountWidth @@ -55,7 +56,8 @@ txUnit :: , 1 <= nBytes , KnownNat aw , 2 <= aw - , 1 <= frameWidth) => + , 1 <= frameWidth + ) => -- | Hardcoded preamble. BitVector preambleWidth -> -- | Local sequence counter. @@ -68,7 +70,8 @@ txUnit :: -- 1. Control register Wishbone bus (Slave -> master). -- 2. Outgoing frame ( Signal core (WishboneS2M (Bytes nBytes)) - , Signal core (DataLink frameWidth)) + , Signal core (DataLink frameWidth) + ) txUnit (getRegsBe -> RegisterBank preamble) sq frameIn wbIn = (wbOut, frameOut) where (stateMachineOn, wbOut) = case timesDivRU @(nBytes * 8) @1 of @@ -81,64 +84,75 @@ txUnit (getRegsBe -> RegisterBank preamble) sq frameIn wbIn = (wbOut, frameOut) stateMachine :: (Unsigned seqCountWidth, TransmissionState preambleWidth seqCountWidth frameWidth) -> (DataLink frameWidth, Unsigned seqCountWidth) -> - ( (Unsigned seqCountWidth - , TransmissionState preambleWidth seqCountWidth frameWidth) - , DataLink frameWidth) + ( ( Unsigned seqCountWidth + , TransmissionState preambleWidth seqCountWidth frameWidth + ) + , DataLink frameWidth + ) stateMachine (scStored@(getRegsBe -> RegisterBank sqVec), state) (fIn, scIn) = ((nextSc, nextState state), out) where (nextSc, out) = case state of - LinkThrough -> (scStored, fIn) + LinkThrough -> (scStored, fIn) TransmitSeqCounter n -> (scStored, Just $ sqVec !! n) TransmitPreamble n - | n == maxBound -> (scIn, Just $ preamble !! n) - | otherwise -> (scStored, Just $ preamble !! n) + | n == maxBound -> (scIn, Just $ preamble !! n) + | otherwise -> (scStored, Just $ preamble !! n) scErr = deepErrorX "txUnit: Stored sequence counter invalid" -- Once turned on, the txUnit continues to transmit the preamble followed by the sequence -- counter. nextState = \case - LinkThrough -> TransmitPreamble 0 - TransmitPreamble n - | n == maxBound -> TransmitSeqCounter 0 - | otherwise -> TransmitPreamble (succ n) - TransmitSeqCounter n - | n == maxBound -> TransmitPreamble 0 - | otherwise -> TransmitSeqCounter (succ n) + LinkThrough -> TransmitPreamble 0 + TransmitPreamble n + | n == maxBound -> TransmitSeqCounter 0 + | otherwise -> TransmitPreamble (succ n) + TransmitSeqCounter n + | n == maxBound -> TransmitPreamble 0 + | otherwise -> TransmitSeqCounter (succ n) -- | States for the rxUnit. data ReceiverState - = Empty - -- ^ Receiver is in idle state. - | WaitingForPreamble - -- ^ Receiver is waiting for the preamble to be detected. - | CaptureSequenceCounter - -- ^ Receiver is capturing the sequence counter. - | Done - -- ^ Receiver has captured a remote and corresponding local sequence counter. + = -- | Receiver is in idle state. + Empty + | -- | Receiver is waiting for the preamble to be detected. + WaitingForPreamble + | -- | Receiver is capturing the sequence counter. + CaptureSequenceCounter + | -- | Receiver has captured a remote and corresponding local sequence counter. + Done deriving (Generic, ShowX, BitPack, NFDataX) --- | We store the remote sequence counter, local sequence counter and 'ReceiverState' --- as a vector of words to make sure they are word-aligned. +{- | We store the remote sequence counter, local sequence counter and 'ReceiverState' +as a vector of words to make sure they are word-aligned. +-} type RxRegister nBytes scw = Vec - ( Regs (Unsigned scw) (nBytes * 8) - + Regs (Unsigned scw) (nBytes * 8) - + Regs ReceiverState (nBytes * 8) - ) - (BitVector (nBytes * 8)) + ( Regs (Unsigned scw) (nBytes * 8) + + Regs (Unsigned scw) (nBytes * 8) + + Regs ReceiverState (nBytes * 8) + ) + (BitVector (nBytes * 8)) {-# NOINLINE rxUnit #-} --- | Receives a Bittide link and can be set to detect the given preamble and capture the --- following sequence counter. + +{- | Receives a Bittide link and can be set to detect the given preamble and capture the +following sequence counter. +-} rxUnit :: - forall core nBytes aw paw fw scw . + forall core nBytes aw paw fw scw. ( HiddenClockResetEnable core - , KnownNat nBytes, 1 <= nBytes - , KnownNat aw, 2 <= aw - , KnownNat paw, 1 <= paw - , KnownNat fw, 1 <= fw - , KnownNat scw, 1 <= scw) => + , KnownNat nBytes + , 1 <= nBytes + , KnownNat aw + , 2 <= aw + , KnownNat paw + , 1 <= paw + , KnownNat fw + , 1 <= fw + , KnownNat scw + , 1 <= scw + ) => -- | Preamble. BitVector paw -> -- | Local sequence counter. @@ -153,74 +167,81 @@ rxUnit preamble localCounter linkIn wbIn = wbOut where (regOut, wbOut) = registerWbE WishbonePriority regInit wbIn regIn (pure maxBound) regInit = mkWordAligned (0 :: Unsigned scw, 0 :: Unsigned scw, Empty) - regIn = unbundle . mealy go - (0,0) $ bundle - ( fmap fromWordAligned regOut, linkIn, localCounter) + regIn = + unbundle + . mealy + go + (0, 0) + $ bundle + (fmap fromWordAligned regOut, linkIn, localCounter) go :: (Index (DivRU scw fw), BitVector paw) -> ( (Unsigned scw, Unsigned scw, ReceiverState) - , DataLink fw, Unsigned scw) -> + , DataLink fw + , Unsigned scw + ) -> ( (Index (DivRU scw fw), BitVector paw) , Maybe (RxRegister nBytes scw) ) go (count, shiftOld) ( ( remoteSc0 - , localSc0 - , state - ) - , link - , localSc1) = - ( (nextCount, shiftNext), mkWordAligned <$> wbRegNew) - where - (remoteSc1, RegisterBank remoteFrames0) = convertBe (RegisterBank newVec, remoteSc0) - where - newVec = tail $ remoteFrames0 :< fromJust link - (shiftNew, RegisterBank oldVec) = convertBe (RegisterBank newVec, shiftOld) + , localSc0 + , state + ) + , link + , localSc1 + ) = + ((nextCount, shiftNext), mkWordAligned <$> wbRegNew) where - newVec = tail $ oldVec :< fromJust link + (remoteSc1, RegisterBank remoteFrames0) = convertBe (RegisterBank newVec, remoteSc0) + where + newVec = tail $ remoteFrames0 :< fromJust link + (shiftNew, RegisterBank oldVec) = convertBe (RegisterBank newVec, shiftOld) + where + newVec = tail $ oldVec :< fromJust link - preambleFound = validFrame && shiftNew == preamble + preambleFound = validFrame && shiftNew == preamble - validFrame = isJust link - firstFrame = validFrame && count == minBound - lastFrame = validFrame && count == maxBound + validFrame = isJust link + firstFrame = validFrame && count == minBound + lastFrame = validFrame && count == maxBound - shiftNext = case (validFrame, state) of - (True, WaitingForPreamble) -> shiftNew - _ -> shiftOld + shiftNext = case (validFrame, state) of + (True, WaitingForPreamble) -> shiftNew + _ -> shiftOld - wbRegNew = case (state, validFrame, firstFrame) of - (WaitingForPreamble ,True,_) -> Just (remoteSc0, localSc0, nextState) - (CaptureSequenceCounter,True,True) -> Just (remoteSc1, localSc1, nextState) - (CaptureSequenceCounter,True,_) -> Just (remoteSc1, localSc0, nextState) - _ -> Nothing + wbRegNew = case (state, validFrame, firstFrame) of + (WaitingForPreamble, True, _) -> Just (remoteSc0, localSc0, nextState) + (CaptureSequenceCounter, True, True) -> Just (remoteSc1, localSc1, nextState) + (CaptureSequenceCounter, True, _) -> Just (remoteSc1, localSc0, nextState) + _ -> Nothing - (nextState, nextCount) = case (preambleFound, lastFrame , state) of - (False, _ , WaitingForPreamble) -> (WaitingForPreamble , 0) - (True , _ , WaitingForPreamble) -> (CaptureSequenceCounter, 0) - (_ , False, CaptureSequenceCounter)-> (CaptureSequenceCounter, succ count) - (_ , True , CaptureSequenceCounter)-> (Done , 0) - _ -> (state , 0) + (nextState, nextCount) = case (preambleFound, lastFrame, state) of + (False, _, WaitingForPreamble) -> (WaitingForPreamble, 0) + (True, _, WaitingForPreamble) -> (CaptureSequenceCounter, 0) + (_, False, CaptureSequenceCounter) -> (CaptureSequenceCounter, succ count) + (_, True, CaptureSequenceCounter) -> (Done, 0) + _ -> (state, 0) mkWordAligned :: - forall wordSize a b c . + forall wordSize a b c. (KnownNat wordSize, 1 <= wordSize, Paddable a, Paddable b, Paddable c) => - (a,b,c) -> + (a, b, c) -> Vec (Regs a wordSize + Regs b wordSize + Regs c wordSize) (BitVector wordSize) - mkWordAligned (a,b,c) = regsA ++ regsB ++ regsC + mkWordAligned (a, b, c) = regsA ++ regsB ++ regsC where RegisterBank regsA = getRegsBe a RegisterBank regsB = getRegsBe b RegisterBank regsC = getRegsBe c fromWordAligned :: - forall wordSize a b c . + forall wordSize a b c. (KnownNat wordSize, 1 <= wordSize, Paddable a, Paddable b, Paddable c) => Vec (Regs a wordSize + Regs b wordSize + Regs c wordSize) (BitVector wordSize) -> - (a,b,c) - fromWordAligned vec = (a,b,c) + (a, b, c) + fromWordAligned vec = (a, b, c) where (vecA, splitAtI -> (vecB, vecC)) = splitAtI vec a = getDataBe (RegisterBank vecA) @@ -239,17 +260,23 @@ data LinkConfig nBytes addrW where GatherConfig nBytes addrW -> LinkConfig nBytes addrW --- | Offers interfaces to connect an incoming 'Bittide.Link' to a 'processingElement', --- consists of a 'rxUnit' and 'scatterUnitWb'. The busses for the --- 'scatterUnitWb's 'calendar' and 'rxUnit' are exposed for the 'managementUnit', --- the bus for the 'scatterUnitWb's memory interface is exposed for the 'processingElement'. +{- | Offers interfaces to connect an incoming 'Bittide.Link' to a 'processingElement', + consists of a 'rxUnit' and 'scatterUnitWb'. The busses for the +'scatterUnitWb's 'calendar' and 'rxUnit' are exposed for the 'managementUnit', +the bus for the 'scatterUnitWb's memory interface is exposed for the 'processingElement'. +-} linkToPe :: - forall dom scw nBytesMu addrWMu addrWPe . + forall dom scw nBytesMu addrWMu addrWPe. ( HiddenClockResetEnable dom - , KnownNat nBytesMu, 1 <= nBytesMu - , KnownNat addrWMu, 2 <= addrWMu - , KnownNat addrWPe, 2 <= addrWPe - , KnownNat scw, 1 <= scw) => + , KnownNat nBytesMu + , 1 <= nBytesMu + , KnownNat addrWMu + , 2 <= addrWMu + , KnownNat addrWPe + , 2 <= addrWPe + , KnownNat scw + , 1 <= scw + ) => -- | Configuration for a 'Bittide.Link', the receiving end uses this for its @preamble@ -- and 'ScatterConfig'. LinkConfig nBytesMu addrWMu -> @@ -265,27 +292,33 @@ linkToPe :: -- ( Slave output for the 'scatterUnitWb's memory interface -- , Slave outputs for the 'rxUnit' and 'scatterUnitWb's 'calendar', respectively) ( Signal dom (WishboneS2M (Bytes 4)) - , Vec 2 (Signal dom (WishboneS2M (Bytes nBytesMu)))) + , Vec 2 (Signal dom (WishboneS2M (Bytes nBytesMu))) + ) linkToPe linkConfig linkIn localCounter peM2S linkM2S = case linkConfig of LinkConfig preamble scatConfig _ -> (peS2M, linkS2M) where - linkS2M = rxS2M :> calS2M :> Nil + linkS2M = rxS2M :> calS2M :> Nil (rxM2S, calM2S) = vecToTuple linkM2S rxS2M = rxUnit preamble localCounter linkIn rxM2S - (peS2M,calS2M) = scatterUnitWb scatConfig calM2S linkIn peM2S - + (peS2M, calS2M) = scatterUnitWb scatConfig calM2S linkIn peM2S --- | Offers interfaces to connect an outgoing 'Bittide.Link' to a 'processingElement', --- consists of a 'txUnit' and 'gatherUnitWb'. The busses for the --- 'gatherUnitWb's 'calendar' and 'txUnit' are exposed for the 'managementUnit', --- the bus for the 'gatherUnitWb's memory interface is exposed for the 'processingElement'. +{- | Offers interfaces to connect an outgoing 'Bittide.Link' to a 'processingElement', + consists of a 'txUnit' and 'gatherUnitWb'. The busses for the +'gatherUnitWb's 'calendar' and 'txUnit' are exposed for the 'managementUnit', +the bus for the 'gatherUnitWb's memory interface is exposed for the 'processingElement'. +-} peToLink :: - forall dom scw nBytesMu addrWMu addrWPe . + forall dom scw nBytesMu addrWMu addrWPe. ( HiddenClockResetEnable dom - , KnownNat nBytesMu, 1 <= nBytesMu - , KnownNat addrWMu, 2 <= addrWMu - , KnownNat addrWPe, 2 <= addrWPe - , KnownNat scw, 1 <= scw) => + , KnownNat nBytesMu + , 1 <= nBytesMu + , KnownNat addrWMu + , 2 <= addrWMu + , KnownNat addrWPe + , 2 <= addrWPe + , KnownNat scw + , 1 <= scw + ) => -- | Configuration for a 'Bittide.Link', the transmitting end uses this for its @preamble@ -- and 'GatherConfig'. LinkConfig nBytesMu addrWMu -> @@ -301,26 +334,29 @@ peToLink :: -- , Slave outputs for the 'txUnit' and 'gatherUnitWb's 'calendar', respectively) ( Signal dom (DataLink 64) , Signal dom (WishboneS2M (Bytes 4)) - , Vec 2 (Signal dom (WishboneS2M (Bytes nBytesMu)))) + , Vec 2 (Signal dom (WishboneS2M (Bytes nBytesMu))) + ) peToLink linkConfig localCounter peM2S linkM2S = case linkConfig of LinkConfig preamble _ gathConfig -> go preamble gathConfig where go :: - forall preambleWidth . - ( KnownNat preambleWidth, 1 <= preambleWidth) => + forall preambleWidth. + (KnownNat preambleWidth, 1 <= preambleWidth) => BitVector preambleWidth -> GatherConfig nBytesMu addrWMu -> ( Signal dom (DataLink 64) , Signal dom (WishboneS2M (Bytes 4)) - , Vec 2 (Signal dom (WishboneS2M (Bytes nBytesMu)))) + , Vec 2 (Signal dom (WishboneS2M (Bytes nBytesMu))) + ) go preamble calConfig = (linkOut, peS2M, linkS2M) where - linkS2M = txS2M :> calS2M :> Nil + linkS2M = txS2M :> calS2M :> Nil (txM2S, calM2S) = vecToTuple linkM2S - (txS2M,linkOut) = txUnit preamble localCounter gatherOut txM2S - (gatherOut, peS2M,calS2M) = gatherUnitWb calConfig calM2S peM2S + (txS2M, linkOut) = txUnit preamble localCounter gatherOut txM2S + (gatherOut, peS2M, calS2M) = gatherUnitWb calConfig calM2S peM2S --- | Counts the number of cycles since the last reset. Initially Unsigned 64 has been --- picked because it's unlikely to overflow in the lifetime of a Bittide system. -sequenceCounter :: HiddenClockResetEnable dom => Signal dom (Unsigned 64) +{- | Counts the number of cycles since the last reset. Initially Unsigned 64 has been + picked because it's unlikely to overflow in the lifetime of a Bittide system. +-} +sequenceCounter :: (HiddenClockResetEnable dom) => Signal dom (Unsigned 64) sequenceCounter = register 0 $ satSucc SatError <$> sequenceCounter diff --git a/bittide/src/Bittide/Node.hs b/bittide/src/Bittide/Node.hs index b89394688..7da573bde 100644 --- a/bittide/src/Bittide/Node.hs +++ b/bittide/src/Bittide/Node.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE GADTs #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-} -{-# LANGUAGE GADTs #-} module Bittide.Node where @@ -22,14 +22,15 @@ import Bittide.ScatterGather import Bittide.SharedTypes import Bittide.Switch -import Control.Arrow ((&&&), (>>>), first) +import Control.Arrow (first, (&&&), (>>>)) --- | A simple node consisting of one external bidirectional link and two 'gppe's. --- This node's 'switch' has a 'CalendarConfig' of for a 'calendar' with up to @1024@ entries, --- however, the 'calendar' is initialized with a single entry of repeated zeroes. --- The 'scatterUnitWb's and 'gatherUnitWb's are initialized with 'CalendarConfig's of all --- zeroes. The 'gppe's initial memories are both undefined and the 'MemoryMap' is a --- vector of ever increasing base addresses (increments of 0x1000). +{- | A simple node consisting of one external bidirectional link and two 'gppe's. +This node's 'switch' has a 'CalendarConfig' of for a 'calendar' with up to @1024@ entries, +however, the 'calendar' is initialized with a single entry of repeated zeroes. +The 'scatterUnitWb's and 'gatherUnitWb's are initialized with 'CalendarConfig's of all +zeroes. The 'gppe's initial memories are both undefined and the 'MemoryMap' is a +vector of ever increasing base addresses (increments of 0x1000). +-} simpleNodeConfig :: NodeConfig 1 2 simpleNodeConfig = NodeConfig @@ -37,28 +38,30 @@ simpleNodeConfig = switchConfig (repeat (GppeConfig linkConfig peConfig)) where - switchConfig = SwitchConfig{ preamble = preamble', calendarConfig = switchCal} + switchConfig = SwitchConfig{preamble = preamble', calendarConfig = switchCal} switchCal = CalendarConfig (SNat @1024) (switchEntry :> Nil) (switchEntry :> Nil) linkConfig = LinkConfig preamble' (ScatterConfig sgConfig) (GatherConfig sgConfig) sgConfig = CalendarConfig (SNat @1024) (sgEntry :> Nil) (sgEntry :> Nil) peConfig = PeConfig memMapPe (Undefined @8192) (Undefined @8192) nmuConfig = PeConfig memMapNmu (Undefined @8192) (Undefined @8192) - memMapPe = iterateI (+0x1000) 0 - memMapNmu = iterateI (+0x1000) 0 + memMapPe = iterateI (+ 0x1000) 0 + memMapNmu = iterateI (+ 0x1000) 0 preamble' = 0xDEADBEEFA5A5A5A5FACADE :: BitVector 96 switchEntry = ValidEntry{veEntry = repeat 0, veRepeat = 0 :: Unsigned 0} - sgEntry = ValidEntry{veEntry = 0 :: Index 1024 , veRepeat = 0 :: Unsigned 0} - --- | Each 'gppe' results in 4 busses for the 'managementUnit', namely: --- * The 'calendar' for the 'scatterUnitWB'. --- * The 'calendar' for the 'gatherUnitWB'. --- * The interface of the 'rxUnit' on the 'gppe' side. --- * The interface of the 'txUnit' on the 'gppe' side. + sgEntry = ValidEntry{veEntry = 0 :: Index 1024, veRepeat = 0 :: Unsigned 0} + +{- | Each 'gppe' results in 4 busses for the 'managementUnit', namely: +* The 'calendar' for the 'scatterUnitWB'. +* The 'calendar' for the 'gatherUnitWB'. +* The interface of the 'rxUnit' on the 'gppe' side. +* The interface of the 'txUnit' on the 'gppe' side. +-} type BussesPerGppe = 4 --- | Each 'switch' link results in 2 busses for the 'managementUnit', namely: --- * The interface of the 'rxUnit' on the 'switch' side. --- * The interface of the 'txUnit' on the 'switch' side. +{- | Each 'switch' link results in 2 busses for the 'managementUnit', namely: +* The interface of the 'rxUnit' on the 'switch' side. +* The interface of the 'txUnit' on the 'switch' side. +-} type BussesPerSwitchLink = 2 -- | Configuration of a 'node'. @@ -69,7 +72,8 @@ data NodeConfig externalLinks gppes where , KnownNat nmuBusses , nmuBusses ~ ((BussesPerGppe * gppes) + switchBusses + 8) , KnownNat nmuRemBusWidth - , nmuRemBusWidth ~ (32 - CLog 2 nmuBusses)) => + , nmuRemBusWidth ~ (32 - CLog 2 nmuBusses) + ) => -- | Configuration for the 'node's 'managementUnit'. ManagementConfig ((BussesPerGppe * gppes) + switchBusses) -> -- | Configuratoin for the 'node's 'switch'. @@ -80,8 +84,8 @@ data NodeConfig externalLinks gppes where -- | A 'node' consists of a 'switch', 'managementUnit' and @0..n@ 'gppe's. node :: - forall dom extLinks gppes . - ( HiddenClockResetEnable dom, KnownNat extLinks, KnownNat gppes) => + forall dom extLinks gppes. + (HiddenClockResetEnable dom, KnownNat extLinks, KnownNat gppes) => NodeConfig extLinks gppes -> Vec extLinks (Signal dom (DataLink 64)) -> Vec extLinks (Signal dom (DataLink 64)) @@ -95,18 +99,23 @@ node (NodeConfig nmuConfig switchConfig gppeConfigs) linksIn = linksOut (swM2Ss, peM2Ss) = splitAtI nmuM2Ss ((swCalM2S, swRxM2Ss), swTxM2Ss) = first (head &&& tail) $ splitAtI swM2Ss - ((swCalS2M, swRxS2Ms), swTxS2Ms) = first (head &&& tail) $ splitAtI - @(1 + (extLinks + (gppes + 1))) @(extLinks + (gppes + 1)) swS2Ms + ((swCalS2M, swRxS2Ms), swTxS2Ms) = + first (head &&& tail) + $ splitAtI + @(1 + (extLinks + (gppes + 1))) + @(extLinks + (gppes + 1)) + swS2Ms nmuS2Ms = swCalS2M :> (swRxS2Ms ++ swTxS2Ms ++ peS2Ms) (pesToSwitch, concat -> peS2Ms) = unzip $ gppe <$> zip3 gppeConfigs switchToPes (unconcatI peM2Ss) --- | Configuration for the 'managementUnit' and its 'Bittide.Link'. --- The management unit contains the 4 wishbone busses that each pe has --- and also the management busses for itself and all other pe's in this node. --- Furthermore it also has access to the 'calendar' for the 'switch'. +{- | Configuration for the 'managementUnit' and its 'Bittide.Link'. +The management unit contains the 4 wishbone busses that each pe has +and also the management busses for itself and all other pe's in this node. +Furthermore it also has access to the 'calendar' for the 'switch'. +-} data ManagementConfig nodeBusses where ManagementConfig :: (KnownNat nodeBusses) => @@ -117,8 +126,9 @@ data ManagementConfig nodeBusses where PeConfig (nodeBusses + 8) -> ManagementConfig nodeBusses --- | Configuration for a general purpose processing element together with its link to the --- switch. +{- | Configuration for a general purpose processing element together with its link to the +switch. +-} data GppeConfig nmuRemBusWidth where GppeConfig :: LinkConfig 4 nmuRemBusWidth -> @@ -130,12 +140,13 @@ data GppeConfig nmuRemBusWidth where {-# NOINLINE gppe #-} --- | A general purpose 'processingElement' to be part of a Bittide Node. It contains --- a 'processingElement', 'linkToPe' and 'peToLink' which create the interface for the --- Bittide Link. It takes a 'GppeConfig', incoming link and four incoming 'WishboneM2S' --- signals and produces the outgoing link alongside four 'WishhboneS2M' signals. --- The order of Wishbone busses is as follows: --- ('rxUnit' :> 'scatterUnitWb' :> 'txUnit' :> 'gatherUnitWb' :> Nil). +{- | A general purpose 'processingElement' to be part of a Bittide Node. It contains +a 'processingElement', 'linkToPe' and 'peToLink' which create the interface for the +Bittide Link. It takes a 'GppeConfig', incoming link and four incoming 'WishboneM2S' +signals and produces the outgoing link alongside four 'WishhboneS2M' signals. +The order of Wishbone busses is as follows: +('rxUnit' :> 'scatterUnitWb' :> 'txUnit' :> 'gatherUnitWb' :> Nil). +-} gppe :: (KnownNat nmuRemBusWidth, 2 <= nmuRemBusWidth, HiddenClockResetEnable dom) => -- | @@ -145,13 +156,15 @@ gppe :: -- ) ( GppeConfig nmuRemBusWidth , Signal dom (DataLink 64) - , Vec 4 (Signal dom (WishboneM2S nmuRemBusWidth 4 (Bytes 4)))) -> + , Vec 4 (Signal dom (WishboneM2S nmuRemBusWidth 4 (Bytes 4))) + ) -> -- | -- ( Outgoing 'Bittide.Link' -- , Outgoing @Vector@ of slave busses -- ) ( Signal dom (DataLink 64) - , Vec 4 (Signal dom (WishboneS2M (Bytes 4)))) + , Vec 4 (Signal dom (WishboneS2M (Bytes 4))) + ) gppe (GppeConfig linkConfig peConfig, linkIn, splitAtI -> (nmuM2S0, nmuM2S1)) = (linkOut, nmuS2M0 ++ nmuS2M1) where @@ -164,25 +177,27 @@ gppe (GppeConfig linkConfig peConfig, linkIn, splitAtI -> (nmuM2S0, nmuM2S1)) = {-# NOINLINE managementUnit #-} --- | A special purpose 'processingElement' that manages a Bittide Node. It contains --- a 'processingElement', 'linkToPe' and 'peToLink' which create the interface for the --- Bittide Link. It takes a 'ManagementConfig', incoming link and a vector of incoming --- 'WishboneS2M' signals and produces the outgoing link alongside a vector of --- 'WishhboneM2S' signals. +{- | A special purpose 'processingElement' that manages a Bittide Node. It contains +a 'processingElement', 'linkToPe' and 'peToLink' which create the interface for the +Bittide Link. It takes a 'ManagementConfig', incoming link and a vector of incoming +'WishboneS2M' signals and produces the outgoing link alongside a vector of +'WishhboneM2S' signals. +-} managementUnit :: - forall dom nodeBusses . + forall dom nodeBusses. (HiddenClockResetEnable dom, KnownNat nodeBusses, CLog 2 (nodeBusses + 8) <= 30) => -- | Configures all local parameters. ManagementConfig nodeBusses -> -- | Incoming 'Bittide.Link'. Signal dom (DataLink 64) -> -- | Incoming @Vector@ of slave busses. - Vec nodeBusses (Signal dom (WishboneS2M (Bytes 4))) -> + Vec nodeBusses (Signal dom (WishboneS2M (Bytes 4))) -> -- | -- ( Outgoing 'Bittide.Link' -- , Outgoing @Vector@ of master busses) ( Signal dom (DataLink 64) - , Vec nodeBusses (Signal dom (WishboneM2S (32 - CLog 2 (nodeBusses + 8)) 4 (Bytes 4)))) + , Vec nodeBusses (Signal dom (WishboneM2S (32 - CLog 2 (nodeBusses + 8)) 4 (Bytes 4))) + ) managementUnit (ManagementConfig linkConfig peConfig) linkIn nodeS2Ms = (linkOut, nodeM2Ss) where diff --git a/bittide/src/Bittide/ProcessingElement.hs b/bittide/src/Bittide/ProcessingElement.hs index b6ed20abf..d5280f3a4 100644 --- a/bittide/src/Bittide/ProcessingElement.hs +++ b/bittide/src/Bittide/ProcessingElement.hs @@ -1,35 +1,38 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} + {-# OPTIONS -fplugin=Protocols.Plugin #-} module Bittide.ProcessingElement where -import Clash.Prelude import Clash.Explicit.Prelude (unsafeOrReset) +import Clash.Prelude import Protocols import Protocols.Wishbone -import VexRiscv (CpuIn(..), CpuOut(..), Jtag, JtagOut(debugReset), vexRiscv) +import VexRiscv (CpuIn (..), CpuOut (..), Jtag, JtagOut (debugReset), vexRiscv) import Bittide.DoubleBufferedRam import Bittide.Extra.Maybe import Bittide.SharedTypes import Bittide.Wishbone -import Clash.Cores.Xilinx.Ila (Depth(D4096)) +import Clash.Cores.Xilinx.Ila (Depth (D4096)) import qualified Data.ByteString as BS -- | Configuration for a Bittide Processing Element. data PeConfig nBusses where PeConfig :: - ( KnownNat depthI, 1 <= depthI - , KnownNat depthD, 1 <= depthD) => + ( KnownNat depthI + , 1 <= depthI + , KnownNat depthD + , 1 <= depthD + ) => -- | The 'MemoryMap' for the contained 'singleMasterInterconnect'. MemoryMap nBusses -> -- | Initial content of the instruction memory, can be smaller than its total depth. @@ -38,16 +41,20 @@ data PeConfig nBusses where InitialContent depthD (Bytes 4) -> PeConfig nBusses --- | VexRiscV based RV32IMC core together with instruction memory, data memory and --- 'singleMasterInterconnect'. +{- | VexRiscV based RV32IMC core together with instruction memory, data memory and +'singleMasterInterconnect'. +-} processingElement :: - forall dom nBusses . + forall dom nBusses. ( HiddenClockResetEnable dom - , KnownNat nBusses, 2 <= nBusses, CLog 2 nBusses <= 30) => + , KnownNat nBusses + , 2 <= nBusses + , CLog 2 nBusses <= 30 + ) => PeConfig nBusses -> Circuit (Jtag dom) - (Vec (nBusses-2) (Wishbone dom 'Standard (MappedBusAddrWidth 32 nBusses) (Bytes 4))) + (Vec (nBusses - 2) (Wishbone dom 'Standard (MappedBusAddrWidth 32 nBusses) (Bytes 4))) processingElement (PeConfig memMapConfig initI initD) = circuit $ \jtagIn -> do (iBus0, dBus0) <- rvCircuit (pure low) (pure low) (pure low) -< jtagIn iBus1 <- ilaWb (SSymbol @"instructionBus") 2 D4096 -< iBus0 @@ -60,23 +67,22 @@ processingElement (PeConfig memMapConfig initI initD) = circuit $ \jtagIn -> do idC -< extBusses where removeMsb :: - forall aw a . - KnownNat aw => + forall aw a. + (KnownNat aw) => Circuit (Wishbone dom 'Standard (aw + 4) a) (Wishbone dom 'Standard aw a) - removeMsb = wbMap (mapAddr (truncateB :: BitVector (aw + 4) -> BitVector aw)) id + removeMsb = wbMap (mapAddr (truncateB :: BitVector (aw + 4) -> BitVector aw)) id wbMap fwd bwd = Circuit $ \(m2s, s2m) -> (fmap bwd s2m, fmap fwd m2s) - -- | Conceptually the same as 'splitAt', but for 'Circuit's splitAtC :: SNat left -> - Circuit (Vec (left + right) a) (Vec left a , Vec right a) + Circuit (Vec (left + right) a) (Vec left a, Vec right a) splitAtC SNat = Circuit go where - go (fwd,(bwdLeft, bwdRight)) = (bwd,(fwdLeft, fwdRight)) + go (fwd, (bwdLeft, bwdRight)) = (bwd, (fwdLeft, fwdRight)) where (fwdLeft, fwdRight) = splitAtI fwd bwd = bwdLeft ++ bwdRight @@ -89,12 +95,13 @@ rvCircuit :: Circuit (Jtag dom) ( Wishbone dom 'Standard 32 (Bytes 4) - , Wishbone dom 'Standard 32 (Bytes 4) ) + , Wishbone dom 'Standard 32 (Bytes 4) + ) rvCircuit tInterrupt sInterrupt eInterrupt = Circuit go where go (jtagIn, (iBusIn, dBusIn)) = (jtagOut, (iBusOut, dBusOut)) where - tupToCoreIn (timerInterrupt, softwareInterrupt, externalInterrupt, iBusWbS2M, dBusWbS2M) = CpuIn {..} + tupToCoreIn (timerInterrupt, softwareInterrupt, externalInterrupt, iBusWbS2M, dBusWbS2M) = CpuIn{..} rvIn = tupToCoreIn <$> bundle (tInterrupt, sInterrupt, eInterrupt, iBusIn, dBusIn) (cpuOut, jtagOut) = vexRiscv hasClock (hasReset `unsafeOrReset` jtagReset) rvIn jtagIn jtagReset = unsafeFromActiveHigh (delay False (bitToBool . debugReset <$> jtagOut)) @@ -111,10 +118,11 @@ mapAddr :: (BitVector aw1 -> BitVector aw2) -> WishboneM2S aw1 selWidth a -> WishboneM2S aw2 selWidth a -mapAddr f wb = wb { addr = f (addr wb) } +mapAddr f wb = wb{addr = f (addr wb)} --- | Stateless wishbone device that only acknowledges writes to address 0. --- Successful writes return the 'writeData' and 'busSelect'. +{- | Stateless wishbone device that only acknowledges writes to address 0. +Successful writes return the 'writeData' and 'busSelect'. +-} wishboneSink :: (KnownNat addressWidth, Paddable dat) => -- | Incoming wishbone bus. @@ -135,9 +143,10 @@ wishboneSink = fmap go output = orNothing acknowledge (busSelect, writeData) wbOut = emptyWishboneS2M{acknowledge, err} --- | Provide a vector of filepaths, and a write operations containing a byteSelect and --- a vector of characters and, for each filepath write the corresponding byte to that file --- if the corresponding byteSelect is @1@. +{- | Provide a vector of filepaths, and a write operations containing a byteSelect and +a vector of characters and, for each filepath write the corresponding byte to that file +if the corresponding byteSelect is @1@. +-} printCharacters :: (KnownNat paths, KnownNat chars, (paths + n) ~ chars) => -- | Destination files for received bytes. @@ -149,9 +158,9 @@ printCharacters Nil _ = pure () printCharacters paths@(Cons _ _) inps = case inps of Just (byteSelect, chars) -> sequence_ $ printToFiles <*> take SNat (unpack byteSelect) <*> take SNat chars - Nothing -> pure () + Nothing -> pure () where printToFiles = printToFile <$> paths printToFile path byteSelect char | byteSelect = BS.appendFile path $ BS.singleton $ bitCoerce char - | otherwise = pure () + | otherwise = pure () diff --git a/bittide/src/Bittide/ProcessingElement/DeviceTreeCompiler.hs b/bittide/src/Bittide/ProcessingElement/DeviceTreeCompiler.hs index eb8e4d6dd..186265c74 100644 --- a/bittide/src/Bittide/ProcessingElement/DeviceTreeCompiler.hs +++ b/bittide/src/Bittide/ProcessingElement/DeviceTreeCompiler.hs @@ -2,10 +2,9 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Bittide.ProcessingElement.DeviceTreeCompiler - ( compileDeviceTreeSource - ) where - +module Bittide.ProcessingElement.DeviceTreeCompiler ( + compileDeviceTreeSource, +) where import Prelude @@ -20,14 +19,13 @@ import System.IO.Temp.Extra import qualified Data.ByteString as BS import qualified System.IO as IO - findDtc :: IO (Maybe FilePath) findDtc = do let process = shell "which dtc" (exitcode, stdout, _) <- readCreateProcessWithExitCode process "" case exitcode of - ExitSuccess -> pure . Just $ dropWhileEnd isSpace stdout + ExitSuccess -> pure . Just $ dropWhileEnd isSpace stdout ExitFailure _ -> pure Nothing compileDeviceTreeSource :: FilePath -> IO (Maybe BS.ByteString) @@ -35,16 +33,16 @@ compileDeviceTreeSource src = withTempBinaryFile "tmp" "fdt.dtb" $ \path _ -> do dtcPathRes <- findDtc case dtcPathRes of Nothing -> do - hPutStrLn IO.stderr + hPutStrLn + IO.stderr "Unable to find device tree compiler on the system. Are you in a Nix shell?" pure Nothing Just dtc -> do - - (exitCode, stdout, stderr) <- readProcessWithExitCode - dtc - ["-O", "dtb", "-b", "0", src, "-o", path] -- args - "" -- stdin - + (exitCode, stdout, stderr) <- + readProcessWithExitCode + dtc + ["-O", "dtb", "-b", "0", src, "-o", path] -- args + "" -- stdin case exitCode of ExitSuccess -> do content <- BS.readFile path diff --git a/bittide/src/Bittide/ProcessingElement/ProgramStream.hs b/bittide/src/Bittide/ProcessingElement/ProgramStream.hs index a33a7a9cf..cef66b4eb 100644 --- a/bittide/src/Bittide/ProcessingElement/ProgramStream.hs +++ b/bittide/src/Bittide/ProcessingElement/ProgramStream.hs @@ -2,21 +2,21 @@ -- -- SPDX-License-Identifier: Apache-2.0 -module Bittide.ProcessingElement.ProgramStream - ( elfStreamStructure - , elfStream - , ZeroPaddingLength - , IsExecutable - , Segment - , Address - ) where +module Bittide.ProcessingElement.ProgramStream ( + elfStreamStructure, + elfStream, + ZeroPaddingLength, + IsExecutable, + Segment, + Address, +) where import Clash.Prelude import Data.Elf import qualified Data.ByteString as BS -import qualified Data.List as L +import qualified Data.List as L type ZeroPaddingLength = BitVector 32 type IsExecutable = Bool @@ -24,46 +24,45 @@ type Segment = (IsExecutable, Address, [BitVector 8], ZeroPaddingLength) type Address = BitVector 32 --- | Parse the contents of an ELF binary and yield the structures --- needed for the streaming format. +{- | Parse the contents of an ELF binary and yield the structures +needed for the streaming format. +-} elfStreamStructure :: BS.ByteString -> (Address, [Segment]) elfStreamStructure contents = let elf = parseElf contents - in readElf elf + in readElf elf --- | Generate a streamable format of the contents of an ELF binary. --- --- The generated stream has the following structure (little endian where needed): --- --- - entry address (32bit) --- - number of segments @s@ (32bit) --- - @s@ segment streams --- --- - bool to indicate if segment is executable or not --- - the starting address of the segment in memory (32bit) --- - the length of the data @d@ to be transmitted (32bit) --- - the amount of zero-padding to add at the end (32bit) --- - the segment contents (@d@ bytes) +{- | Generate a streamable format of the contents of an ELF binary. + +The generated stream has the following structure (little endian where needed): + +- entry address (32bit) +- number of segments @s@ (32bit) +- @s@ segment streams + + - bool to indicate if segment is executable or not + - the starting address of the segment in memory (32bit) + - the length of the data @d@ to be transmitted (32bit) + - the amount of zero-padding to add at the end (32bit) + - the segment contents (@d@ bytes) +-} elfStream :: BS.ByteString -> [BitVector 8] elfStream contents = let (addr, segs) = elfStreamStructure contents - in - bvToLE addr - <> bvToLE (fromIntegral $ L.length segs) - <> L.concatMap segmentStream segs - - where - segmentStream :: Segment -> [BitVector 8] - segmentStream (isExec, addr, dat, padding) = - (if isExec then 1 else 0) - : bvToLE addr - <> bvToLE (fromIntegral $ L.length dat) - <> bvToLE padding - <> dat - - bvToLE :: BitVector 32 -> [BitVector 8] - bvToLE (bitCoerce -> (a, b, c, d)) = [d, c, b, a] + in bvToLE addr + <> bvToLE (fromIntegral $ L.length segs) + <> L.concatMap segmentStream segs + where + segmentStream :: Segment -> [BitVector 8] + segmentStream (isExec, addr, dat, padding) = + (if isExec then 1 else 0) + : bvToLE addr + <> bvToLE (fromIntegral $ L.length dat) + <> bvToLE padding + <> dat + bvToLE :: BitVector 32 -> [BitVector 8] + bvToLE (bitCoerce -> (a, b, c, d)) = [d, c, b, a] readElf :: Elf -> (Address, [Segment]) readElf elf = @@ -72,15 +71,12 @@ readElf elf = where go seg acc -- skip segments that don't need loading - | elfSegmentType seg /= PT_LOAD - = acc - - | PF_X `elem` elfSegmentFlags seg - = streamSegment True seg : acc - - | PF_R `elem` elfSegmentFlags seg - = streamSegment False seg : acc - + | elfSegmentType seg /= PT_LOAD = + acc + | PF_X `elem` elfSegmentFlags seg = + streamSegment True seg : acc + | PF_R `elem` elfSegmentFlags seg = + streamSegment False seg : acc | otherwise = acc bytes str = pack <$> BS.unpack str @@ -93,4 +89,5 @@ readElf elf = memSz = fromIntegral $ elfSegmentMemSize seg zeroPadding = memSz - fileSz addr = fromIntegral $ elfSegmentPhysAddr seg - in (isExec, addr, bytes segData, zeroPadding) + in + (isExec, addr, bytes segData, zeroPadding) diff --git a/bittide/src/Bittide/ProcessingElement/ReadElf.hs b/bittide/src/Bittide/ProcessingElement/ReadElf.hs index 0c9d4bb91..0c9d9313d 100644 --- a/bittide/src/Bittide/ProcessingElement/ReadElf.hs +++ b/bittide/src/Bittide/ProcessingElement/ReadElf.hs @@ -9,9 +9,9 @@ import Clash.Prelude import Data.Elf -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.IntMap.Strict as I -import qualified Data.List as L +import qualified Data.List as L type BinaryData = I.IntMap (BitVector 8) type Address = BitVector 32 @@ -19,12 +19,13 @@ type Address = BitVector 32 readElfFromMemory :: BS.ByteString -> (Address, BinaryData, BinaryData) readElfFromMemory contents = let elf = parseElf contents - in readElf elf + in readElf elf --- | readElf :: elf file -> (initial PC, instructions, data) --- --- TODO Check the ELF header is valid: is this RISCV? Is it RV32IMC? --- TODO Binaries output now are SYS V ABI, are others compatible? +{- | readElf :: elf file -> (initial PC, instructions, data) + +TODO Check the ELF header is valid: is this RISCV? Is it RV32IMC? +TODO Binaries output now are SYS V ABI, are others compatible? +-} readElf :: Elf -> (Address, BinaryData, BinaryData) readElf elf = let (iMem, dMem) = L.foldr go (mempty, mempty) (elfSegments elf) @@ -32,22 +33,25 @@ readElf elf = where go seg acc@(is, ds) -- skip segments that don't need loading - | elfSegmentType seg /= PT_LOAD - = acc - - | PF_X `elem` elfSegmentFlags seg - = (addData (elfSegmentPhysAddr seg) (bytes $ elfSegmentData seg `BS.append` BS.pack [0,0]) is, ds) - - | otherwise - = let - segData = elfSegmentData seg - fileSz = fromIntegral $ BS.length segData - memSz = fromIntegral $ elfSegmentMemSize seg - data' = bytes segData <> L.replicate (memSz - fileSz) 0 - in - (is, addData (elfSegmentPhysAddr seg) data' ds) + | elfSegmentType seg /= PT_LOAD = + acc + | PF_X `elem` elfSegmentFlags seg = + ( addData + (elfSegmentPhysAddr seg) + (bytes $ elfSegmentData seg `BS.append` BS.pack [0, 0]) + is + , ds + ) + | otherwise = + let + segData = elfSegmentData seg + fileSz = fromIntegral $ BS.length segData + memSz = fromIntegral $ elfSegmentMemSize seg + data' = bytes segData <> L.replicate (memSz - fileSz) 0 + in + (is, addData (elfSegmentPhysAddr seg) data' ds) bytes str = pack <$> BS.unpack str addData (fromIntegral -> startAddr) dat mem = - I.fromList (L.zip [startAddr..] dat) <> mem + I.fromList (L.zip [startAddr ..] dat) <> mem diff --git a/bittide/src/Bittide/ProcessingElement/Util.hs b/bittide/src/Bittide/ProcessingElement/Util.hs index ac9c99225..41269edf4 100644 --- a/bittide/src/Bittide/ProcessingElement/Util.hs +++ b/bittide/src/Bittide/ProcessingElement/Util.hs @@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE NumericUnderscores #-} + module Bittide.ProcessingElement.Util where import Clash.Prelude hiding (Exp) @@ -16,30 +17,37 @@ import GHC.Stack import Language.Haskell.TH import Numeric (showHex) import System.Exit -import System.IO (stderr, hPutStrLn) +import System.IO (hPutStrLn, stderr) import qualified Data.ByteString as BS import qualified Data.IntMap as I import qualified Data.List as L --- | Given a `Maybe Int` and a list, if the `Maybe Int` is `Just s`, pad the list to --- size `s` with the given element. If the length of the list is greater than `s`, --- throw an error. If the `Maybe Int` is `Nothing`, return the list as is. -padToSize :: HasCallStack => String -> Maybe Int -> a -> [a] -> [a] +{- | Given a `Maybe Int` and a list, if the `Maybe Int` is `Just s`, pad the list to +size `s` with the given element. If the length of the list is greater than `s`, +throw an error. If the `Maybe Int` is `Nothing`, return the list as is. +-} +padToSize :: (HasCallStack) => String -> Maybe Int -> a -> [a] -> [a] padToSize _ Nothing _ l = l padToSize name (Just s) a xs | s >= l = xs <> L.replicate (s - l) a - | otherwise = error $ "Bittide.ProcessingElement.Util: " <> name <> " with length " <> - show l <> " is longer than the specified size " <> show s - where - l = L.length xs - + | otherwise = + error + $ "Bittide.ProcessingElement.Util: " + <> name + <> " with length " + <> show l + <> " is longer than the specified size " + <> show s + where + l = L.length xs --- | Given the path to an elf file, the path to a device tree and a starting address --- for the device tree. Return a 3 tuple containing: --- (initial program counter, instruction memory blob, data memory blob) +{- | Given the path to an elf file, the path to a device tree and a starting address + for the device tree. Return a 3 tuple containing: + (initial program counter, instruction memory blob, data memory blob) +-} memBlobsFromElf :: - HasCallStack => + (HasCallStack) => -- | How the words should be ordered in the memBlob ByteOrder -> -- | Optional size in bytes to which we should pad the instruction memBlob and data memBlob. @@ -50,32 +58,35 @@ memBlobsFromElf :: -- | Optional tuple of starting address and filepath to a device tree. Maybe (I.Key, FilePath) -> -- | (instruction memBlob, data memBlob) - Q Exp + Q Exp memBlobsFromElf byteOrder (iSize, dSize) elfPath maybeDeviceTree = do (iMemIntMap, dMemIntMap) <- runIO (getBytesMems elfPath maybeDeviceTree) let (_iStartAddr, _, iList) = extractIntMapData byteOrder iMemIntMap (_dStartAddr, _, dList) = extractIntMapData byteOrder dMemIntMap - iListPadded = padToSize "Instruction memory" (fmap ((`div` 4) . (+3)) iSize) 0 iList - dListPadded = padToSize "Data memory" (fmap ((`div` 4) . (+3)) dSize) 0 dList + iListPadded = padToSize "Instruction memory" (fmap ((`div` 4) . (+ 3)) iSize) 0 iList + dListPadded = padToSize "Data memory" (fmap ((`div` 4) . (+ 3)) dSize) 0 dList iBlob = memBlobTH Nothing iListPadded dBlob = memBlobTH Nothing dListPadded [|($iBlob, $dBlob)|] --- | Given the path to an elf file, the path to a device tree and a starting address --- for the device tree. Return a 3 tuple containing: --- Return a 3 tuple containing (initial program counter, instruction memory blob, data memory blob) +{- | Given the path to an elf file, the path to a device tree and a starting address + for the device tree. Return a 3 tuple containing: +Return a 3 tuple containing (initial program counter, instruction memory blob, data memory blob) +-} getBytesMems :: FilePath -> Maybe (I.Key, FilePath) -> IO (I.IntMap Byte, I.IntMap Byte) getBytesMems elfPath maybeDeviceTree = do - elfBytes <- BS.readFile elfPath let (entry, iMem, dMem0) = readElfFromMemory elfBytes when (entry /= 0x8000_0000) $ do - hPutStrLn stderr $ - "Entry point of ELF file at " <> show elfPath <> - " must be 0x80000000. Found 0x" <> showHex entry "" <> " instead" + hPutStrLn stderr + $ "Entry point of ELF file at " + <> show elfPath + <> " must be 0x80000000. Found 0x" + <> showHex entry "" + <> " instead" exitFailure -- add device tree as a memory mapped component @@ -83,9 +94,15 @@ getBytesMems elfPath maybeDeviceTree = do let fdtAddr = maybe 0 fst maybeDeviceTree deviceTreeMap = I.fromList (L.zip [fdtAddr ..] deviceTree) - dMem1 = I.unionWithKey (\k _ _ -> error $ - "Bittide.ProcessingElement.Util: Overlapping element in data memory and device tree at address 0x" - <> showHex k "") dMem0 deviceTreeMap + dMem1 = + I.unionWithKey + ( \k _ _ -> + error + $ "Bittide.ProcessingElement.Util: Overlapping element in data memory and device tree at address 0x" + <> showHex k "" + ) + dMem0 + deviceTreeMap pure (iMem, if isJust maybeDeviceTree then dMem1 else dMem0) @@ -103,7 +120,7 @@ extractIntMapData byteOrder dataMap = (resize . bitCoerce $ startAddr, size, com where combineFunction | LittleEndian <- byteOrder = toWordsLinear - | BigEndian <- byteOrder = toWordsSwapped + | BigEndian <- byteOrder = toWordsSwapped ordList = I.toAscList dataMap startAddr = fst $ L.head ordList @@ -112,34 +129,35 @@ extractIntMapData byteOrder dataMap = (resize . bitCoerce $ startAddr, size, com snd (L.head ordList) : flattenContent startAddr (L.tail ordList) flattenContent _ [] = [] - flattenContent prevAddr ((nextAddr, val):vals) = + flattenContent prevAddr ((nextAddr, val) : vals) = let n = nextAddr - prevAddr - 1 padding = L.replicate n 0 - in padding L.++ (val : flattenContent nextAddr vals) + in + padding L.++ (val : flattenContent nextAddr vals) toWordsLinear :: [Bytes 1] -> [Bytes 4] toWordsLinear [] = [] toWordsLinear [!a] = [bitCoerce (a, 0 :: Bytes 3)] toWordsLinear [!a, !b] = [bitCoerce (a, b, 0 :: Bytes 2)] toWordsLinear [!a, !b, !c] = [bitCoerce (a, b, c, 0 :: Bytes 1)] - toWordsLinear ((!a):(!b):(!c):(!d):rest) = bitCoerce (a, b, c, d) : toWordsLinear rest + toWordsLinear ((!a) : (!b) : (!c) : (!d) : rest) = bitCoerce (a, b, c, d) : toWordsLinear rest toWordsSwapped :: [Bytes 1] -> [Bytes 4] toWordsSwapped [] = [] toWordsSwapped [!a] = [bitCoerce (a, 0 :: Bytes 3)] toWordsSwapped [!a, !b] = [bitCoerce (b, a, 0 :: Bytes 2)] toWordsSwapped [!a, !b, !c] = [bitCoerce (c, b, a, 0 :: Bytes 1)] - toWordsSwapped ((!a):(!b):(!c):(!d):rest) = bitCoerce (d, c, b, a) : toWordsSwapped rest + toWordsSwapped ((!a) : (!b) : (!c) : (!d) : rest) = bitCoerce (d, c, b, a) : toWordsSwapped rest -- | Given the filepath to a device tree, return the divce tree as list of `Byte`. readDeviceTree :: FilePath -> IO [Byte] readDeviceTree deviceTreePath = do - compileRes <- compileDeviceTreeSource deviceTreePath + compileRes <- compileDeviceTreeSource deviceTreePath - deviceTreeRaw <- maybe exitFailure pure compileRes + deviceTreeRaw <- maybe exitFailure pure compileRes - let - padding = L.replicate (4 - (BS.length deviceTreeRaw `mod` 4)) 0 + let + padding = L.replicate (4 - (BS.length deviceTreeRaw `mod` 4)) 0 - pure (fmap pack . BS.unpack $ deviceTreeRaw <> BS.pack padding) + pure (fmap pack . BS.unpack $ deviceTreeRaw <> BS.pack padding) diff --git a/bittide/src/Bittide/ScatterGather.hs b/bittide/src/Bittide/ScatterGather.hs index d6c620915..a410056e8 100644 --- a/bittide/src/Bittide/ScatterGather.hs +++ b/bittide/src/Bittide/ScatterGather.hs @@ -1,18 +1,17 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GADTs #-} -module Bittide.ScatterGather - ( scatterUnitWb - , ScatterConfig(..) - , gatherUnitWb - , GatherConfig(..) - ) where +module Bittide.ScatterGather ( + scatterUnitWb, + ScatterConfig (..), + gatherUnitWb, + GatherConfig (..), +) where import Clash.Prelude @@ -23,34 +22,41 @@ import Bittide.DoubleBufferedRam import Bittide.Extra.Maybe import Bittide.SharedTypes --- | Existential type to explicitly differentiate between a configuration for --- the 'scatterUnitWb' and 'gatherUnitWb' at type level and hide the memory depth from --- higher level APIs. +{- | Existential type to explicitly differentiate between a configuration for +the 'scatterUnitWb' and 'gatherUnitWb' at type level and hide the memory depth from +higher level APIs. +-} data ScatterConfig nBytes addrW where ScatterConfig :: (KnownNat memDepth, 1 <= memDepth) => (CalendarConfig nBytes addrW (Index memDepth)) -> ScatterConfig nBytes addrW --- | Existential type to explicitly differentiate between a configuration for --- the 'scatterUnitWb' and 'gatherUnitWb' at type level and hide the memory depth from --- higher level APIs. +{- | Existential type to explicitly differentiate between a configuration for +the 'scatterUnitWb' and 'gatherUnitWb' at type level and hide the memory depth from +higher level APIs. +-} data GatherConfig nBytes addrW where GatherConfig :: (KnownNat memDepth, 1 <= memDepth) => (CalendarConfig nBytes addrW (Index memDepth)) -> GatherConfig nBytes addrW --- | Double buffered memory component that can be written to by a Bittide link. The write --- address of the incoming frame is determined by the incorporated 'calendar'. The buffers --- are swapped at the beginning of each metacycle. Reading the buffer is done by supplying --- a read address. Furthermore this component offers ports to control the incorporated 'calendar'. +{- | Double buffered memory component that can be written to by a Bittide link. The write +address of the incoming frame is determined by the incorporated 'calendar'. The buffers +are swapped at the beginning of each metacycle. Reading the buffer is done by supplying +a read address. Furthermore this component offers ports to control the incorporated 'calendar'. +-} scatterUnit :: ( HiddenClockResetEnable dom - , KnownNat memDepth, 1 <= memDepth + , KnownNat memDepth + , 1 <= memDepth , KnownNat frameWidth - , KnownNat nBytes, 1 <= nBytes - , KnownNat addrW, 2 <= addrW) => + , KnownNat nBytes + , 1 <= nBytes + , KnownNat addrW + , 2 <= addrW + ) => -- | Configuration for the 'calendar'. CalendarConfig nBytes addrW (Index memDepth) -> -- | Wishbone (master -> slave) port for the 'calendar'. @@ -62,7 +68,10 @@ scatterUnit :: -- | 1. Data at read address delayed 1 cycle -- 2. Wishbone (slave -> master) from 'calendar') -- 3. End of metacycle. - (Signal dom (BitVector frameWidth), Signal dom (WishboneS2M (Bytes nBytes)), Signal dom Bool) + ( Signal dom (BitVector frameWidth) + , Signal dom (WishboneS2M (Bytes nBytes)) + , Signal dom Bool + ) scatterUnit calConfig wbIn linkIn readAddr = (readOut, wbOut, endOfMetacycle) where (writeAddr, endOfMetacycle, wbOut) = mkCalendar calConfig wbIn @@ -71,18 +80,25 @@ scatterUnit calConfig wbIn linkIn readAddr = (readOut, wbOut, endOfMetacycle) bufSelect0 = register A bufSelect1 bufSelect1 = mux endOfMetacycle (swapAorB <$> bufSelect0) bufSelect0 --- | Double buffered memory component that can be written to by a generic write operation. The --- write address of the incoming frame is determined by the incorporated 'calendar'. The --- buffers are swapped at the beginning of each metacycle. Reading the buffer is done by --- supplying a read address. Furthermore this component offers ports to control the --- incorporated 'calendar'. +{- | Double buffered memory component that can be written to by a generic write operation. The +write address of the incoming frame is determined by the incorporated 'calendar'. The +buffers are swapped at the beginning of each metacycle. Reading the buffer is done by +supplying a read address. Furthermore this component offers ports to control the +incorporated 'calendar'. +-} gatherUnit :: ( HiddenClockResetEnable dom - , KnownNat memDepth, 1 <= memDepth - , KnownNat frameWidth, 1 <= frameWidth - , KnownNat (DivRU frameWidth 8), 1 <= (DivRU frameWidth 8) - , KnownNat nBytes, 1 <= nBytes - , KnownNat addrW, 2 <= addrW) => + , KnownNat memDepth + , 1 <= memDepth + , KnownNat frameWidth + , 1 <= frameWidth + , KnownNat (DivRU frameWidth 8) + , 1 <= (DivRU frameWidth 8) + , KnownNat nBytes + , 1 <= nBytes + , KnownNat addrW + , 2 <= addrW + ) => -- | Configuration for the 'calendar'. CalendarConfig nBytes addrW (Index memDepth) -> -- | Wishbone (master -> slave) port for the 'calendar'. @@ -94,22 +110,29 @@ gatherUnit :: -- | 1. Frame to Bittide Link. -- 2. Wishbone (slave -> master) from 'calendar') -- 3. End of metacycle. - (Signal dom (DataLink frameWidth), Signal dom (WishboneS2M (Bytes nBytes)), Signal dom Bool) + ( Signal dom (DataLink frameWidth) + , Signal dom (WishboneS2M (Bytes nBytes)) + , Signal dom Bool + ) gatherUnit calConfig wbIn writeOp byteEnables = (linkOut, wbOut, endOfMetacycle) where (readAddr, endOfMetacycle, wbOut) = mkCalendar calConfig wbIn - linkOut = mux (register True ((==0) <$> readAddr)) (pure Nothing) (Just <$> bramOut) + linkOut = mux (register True ((== 0) <$> readAddr)) (pure Nothing) (Just <$> bramOut) bramOut = doubleBufferedRamByteAddressableU bufSelect0 readAddr writeOp byteEnables bufSelect0 = register A bufSelect1 bufSelect1 = mux endOfMetacycle (swapAorB <$> bufSelect0) bufSelect0 --- | Wishbone interface for the 'scatterUnit' and 'gatherUnit'. It makes the scatter and gather --- unit, which operate on 64 bit frames, addressable via a 32 bit wishbone bus. +{- | Wishbone interface for the 'scatterUnit' and 'gatherUnit'. It makes the scatter and gather +unit, which operate on 64 bit frames, addressable via a 32 bit wishbone bus. +-} wbInterface :: - forall nBytes addrW addresses . + forall nBytes addrW addresses. ( KnownNat nBytes - , KnownNat addresses, 1 <= addresses - , KnownNat addrW, 2 <= addrW) => + , KnownNat addresses + , 1 <= addresses + , KnownNat addrW + , 2 <= addrW + ) => -- | Wishbone (master -> slave) data. WishboneM2S addrW nBytes (Bytes nBytes) -> -- | Read data to be send to over the (slave -> master) port. @@ -117,9 +140,10 @@ wbInterface :: -- | (slave - master data, read address memory element, write data memory element) (WishboneS2M (Bytes nBytes), Index addresses, Maybe (Bytes nBytes)) wbInterface WishboneM2S{..} readData = - ( (emptyWishboneS2M @(Bytes nBytes)) {readData, acknowledge, err} + ( (emptyWishboneS2M @(Bytes nBytes)){readData, acknowledge, err} , wbAddr - , writeOp ) + , writeOp + ) where masterActive = strobe && busCycle (alignedAddress, alignment) = split @_ @(addrW - 2) @2 addr @@ -130,11 +154,12 @@ wbInterface WishboneM2S{..} readData = wbAddr = unpack . resize $ pack alignedAddress writeOp = orNothing (strobe && writeEnable && not err) writeData --- | Adds a stalling address to the 'wbInterface' by demanding an extra address on type level. --- When this address is accessed, the outgoing 'WishboneS2M' bus' acknowledge is replaced --- with the @endOfMetacycle@ signal to stall the wishbone master until the end of the metacycle. +{- | Adds a stalling address to the 'wbInterface' by demanding an extra address on type level. +When this address is accessed, the outgoing 'WishboneS2M' bus' acknowledge is replaced +with the @endOfMetacycle@ signal to stall the wishbone master until the end of the metacycle. +-} addStalling :: - ( KnownNat memAddresses, 1 <= memAddresses) => + (KnownNat memAddresses, 1 <= memAddresses) => -- | Controls the 'acknowledge' of the returned 'WishboneS2M' when the incoming address -- is 'maxBound'. Bool -> @@ -144,33 +169,41 @@ addStalling :: -- 3. Incoming write operation. ( WishboneS2M wbData , Index (memAddresses + 1) - , Maybe a) -> + , Maybe a + ) -> -- | -- 1. Outgoing 'WishboneS2M' bus (@acknowledge@ replaced with @endOfMetacycle@ when @wbAddr == maxBound@). -- 2. Outgoing wishbone address (stalling address not in range). -- 3. Outgoing write operation (set to @Nothing@ when @wbAddr == maxBound@). ( WishboneS2M wbData , Index memAddresses - , Maybe a) + , Maybe a + ) addStalling endOfMetacycle (incomingBus@WishboneS2M{..}, wbAddr, writeOp0) = (slaveToMaster1, memAddr, writeOp1) where stalledBus = incomingBus{acknowledge = endOfMetacycle} (slaveToMaster1, writeOp1) | acknowledge && (wbAddr == maxBound) = (stalledBus, Nothing) - | otherwise = (incomingBus, writeOp0) + | otherwise = (incomingBus, writeOp0) memAddr = bitCoerce $ resize wbAddr {-# NOINLINE scatterUnitWb #-} --- | Wishbone addressable 'scatterUnit', the wishbone port can read the data from this --- memory element as if it has a 32 bit port by selecting the upper 32 or lower 32 bits --- of the read data. + +{- | Wishbone addressable 'scatterUnit', the wishbone port can read the data from this +memory element as if it has a 32 bit port by selecting the upper 32 or lower 32 bits +of the read data. +-} scatterUnitWb :: - forall dom addrWidthSu nBytesCal addrWidthCal . + forall dom addrWidthSu nBytesCal addrWidthCal. ( HiddenClockResetEnable dom - , KnownNat addrWidthSu, 2 <= addrWidthSu - , KnownNat nBytesCal, 1 <= nBytesCal - , KnownNat addrWidthCal, 2 <= addrWidthCal) => + , KnownNat addrWidthSu + , 2 <= addrWidthSu + , KnownNat nBytesCal + , 1 <= nBytesCal + , KnownNat addrWidthCal + , 2 <= addrWidthCal + ) => -- | Configuration for the 'calendar'. ScatterConfig nBytesCal addrWidthCal -> -- | Wishbone (master -> slave) port 'calendar'. @@ -186,8 +219,11 @@ scatterUnitWb :: scatterUnitWb (ScatterConfig calConfig) wbInCal linkIn wbInSu = (delayControls wbOutSu, wbOutCal) where - (wbOutSu, memAddr, _) = unbundle $ addStalling <$> endOfMetacycle <*> - (wbInterface <$> wbInSu <*> scatteredData) + (wbOutSu, memAddr, _) = + unbundle + $ addStalling + <$> endOfMetacycle + <*> (wbInterface <$> wbInSu <*> scatteredData) (readAddr, upperSelected) = unbundle $ div2Index <$> memAddr (scatterUnitRead, wbOutCal, endOfMetacycle) = scatterUnit calConfig wbInCal linkIn readAddr @@ -196,15 +232,21 @@ scatterUnitWb (ScatterConfig calConfig) wbInCal linkIn wbInSu = scatteredData = mux selected upper lower {-# NOINLINE gatherUnitWb #-} --- | Wishbone addressable 'gatherUnit', the wishbone port can write data to this --- memory element as if it has a 32 bit port by controlling the byte enables of the --- 'gatherUnit' based on the third bit. + +{- | Wishbone addressable 'gatherUnit', the wishbone port can write data to this +memory element as if it has a 32 bit port by controlling the byte enables of the +'gatherUnit' based on the third bit. +-} gatherUnitWb :: - forall dom addrWidthGu nBytesCal addrWidthCal . + forall dom addrWidthGu nBytesCal addrWidthCal. ( HiddenClockResetEnable dom - , KnownNat addrWidthGu, 2 <= addrWidthGu - , KnownNat nBytesCal, 1 <= nBytesCal - , KnownNat addrWidthCal, 2 <= addrWidthCal) => + , KnownNat addrWidthGu + , 2 <= addrWidthGu + , KnownNat nBytesCal + , 1 <= nBytesCal + , KnownNat addrWidthCal + , 2 <= addrWidthCal + ) => -- | Configuration for the 'calendar'. GatherConfig nBytesCal addrWidthCal -> -- | Wishbone (master -> slave) data 'calendar'. @@ -216,12 +258,16 @@ gatherUnitWb :: -- 2. Wishbone (slave -> master) port 'calendar' ( Signal dom (DataLink 64) , Signal dom (WishboneS2M (Bytes 4)) - , Signal dom (WishboneS2M (Bytes nBytesCal)) ) + , Signal dom (WishboneS2M (Bytes nBytesCal)) + ) gatherUnitWb (GatherConfig calConfig) wbInCal wbInGu = (linkOut, delayControls wbOutGu, wbOutCal) where - (wbOutGu, memAddr, writeOp) = unbundle $ addStalling <$> endOfMetacycle <*> - (wbInterface <$> wbInGu <*> pure 0b0) + (wbOutGu, memAddr, writeOp) = + unbundle + $ addStalling + <$> endOfMetacycle + <*> (wbInterface <$> wbInGu <*> pure 0b0) (writeAddr, upperSelected) = unbundle $ div2Index <$> memAddr (linkOut, wbOutCal, endOfMetacycle) = gatherUnit calConfig wbInCal gatherWrite gatherByteEnables @@ -234,5 +280,5 @@ gatherUnitWb (GatherConfig calConfig) wbInCal wbInGu = mkWrite address (Just write) = Just (address, write ++# write) mkWrite _ _ = Nothing mkEnables selected byteEnables - | selected = 0 ++# byteEnables + | selected = 0 ++# byteEnables | otherwise = byteEnables ++# 0 diff --git a/bittide/src/Bittide/SharedTypes.hs b/bittide/src/Bittide/SharedTypes.hs index cc1752faf..9b6b936f6 100644 --- a/bittide/src/Bittide/SharedTypes.hs +++ b/bittide/src/Bittide/SharedTypes.hs @@ -1,9 +1,3 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - -{-# OPTIONS_GHC -fconstraint-solver-iterations=8 #-} - {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -12,13 +6,18 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=8 #-} + module Bittide.SharedTypes where import Clash.Prelude import Data.Constraint import Data.Constraint.Nat.Extra -import Data.Type.Equality ((:~:)(Refl)) +import Data.Type.Equality ((:~:) (Refl)) import Protocols.Wishbone -- | To be used when there are two options. @@ -45,12 +44,16 @@ resizeM2SAddr WishboneM2S{..} = WishboneM2S{addr = resize addr, ..} -- | A single byte. type Byte = BitVector 8 + -- | BitVector of _n_ bytes. -type Bytes n = BitVector (n*8) +type Bytes n = BitVector (n * 8) + -- | A BitVector that contains one bit per byte in the BitSize of a. type ByteEnable a = BitVector (Regs a 8) + -- | Either contains a @Just (BitVector frameWidth)@ or @Nothing@. type DataLink frameWidth = Maybe (BitVector frameWidth) + -- | Type synonym that constrains @a@ and @b@ to both be @KnownNat@ and that @a <= b@. type LessThan a b = (KnownNat a, KnownNat b, a <= b) @@ -70,105 +73,124 @@ type Paddable a = (BitPack a, NFDataX a) -- | @writeData@ has a relation with @Index maxIndex@. type Located maxIndex writeData = (Index maxIndex, writeData) + -- | @BitVector bits@ has a relation with @Index maxIndex@. type LocatedBits maxIndex bits = Located maxIndex (BitVector bits) + -- | 'Byte' has a relation with @Index maxIndex@. type LocatedByte maxIndex = Located maxIndex Byte + -- | 'Bytes' has a relation with @Index maxIndex@. type LocatedBytes maxIndex nBytes = Located maxIndex (Bytes nBytes) -- Padding bits added when a is stored in multiples of bw bits. -type Pad a bw = (Regs a bw * bw) - BitSize a +type Pad a bw = (Regs a bw * bw) - BitSize a + -- Amount of bw sized registers required to store a. type Regs a bw = DivRU (BitSize a) bw data ByteOrder = LittleEndian | BigEndian - deriving Eq + deriving (Eq) -- | Stores any arbitrary datatype as a vector of registers. -newtype RegisterBank regSize content (byteOrder :: ByteOrder) = - RegisterBank (Vec (Regs content regSize) (BitVector regSize)) - deriving Generic - -instance (KnownNat regSize, 1 <= regSize, BitPack content) => - BitPack (RegisterBank regSize content byteOrder) where - type BitSize (RegisterBank regSize content byteOrder) = - Regs content regSize * regSize +newtype RegisterBank regSize content (byteOrder :: ByteOrder) + = RegisterBank (Vec (Regs content regSize) (BitVector regSize)) + deriving (Generic) + +instance + (KnownNat regSize, 1 <= regSize, BitPack content) => + BitPack (RegisterBank regSize content byteOrder) + where + type + BitSize (RegisterBank regSize content byteOrder) = + Regs content regSize * regSize pack (RegisterBank vec) = pack vec unpack bv = RegisterBank (unpack bv) deriving newtype instance - (KnownNat regSize, 1 <= regSize, Paddable content, NFDataX (RegisterBank regSize content byteOrder)) - => NFDataX (RegisterBank regSize content byteOrder) + ( KnownNat regSize + , 1 <= regSize + , Paddable content + , NFDataX (RegisterBank regSize content byteOrder) + ) => + NFDataX (RegisterBank regSize content byteOrder) -deriving newtype instance (KnownNat regSize, ShowX (RegisterBank regSize content byteOrder)) => +deriving newtype instance + (KnownNat regSize, ShowX (RegisterBank regSize content byteOrder)) => ShowX (RegisterBank regSize content byteOrder) convertBe :: (Paddable a, KnownNat bw, 1 <= bw) => - (RegisterBank bw a 'BigEndian, a) -> + (RegisterBank bw a 'BigEndian, a) -> (a, RegisterBank bw a 'BigEndian) convertBe (regBank, a) = (getDataBe regBank, getRegsBe a) -- | Transforms a to _RegisterBank_. getRegsLe :: - forall bw a . - (Paddable a, KnownNat bw, 1 <= bw) - => a - -> RegisterBank bw a 'LittleEndian + forall bw a. + (Paddable a, KnownNat bw, 1 <= bw) => + a -> + RegisterBank bw a 'LittleEndian getRegsLe a = case timesDivRU @bw @(BitSize a) of - Dict -> RegisterBank (reverse $ bitCoerce (0 :: BitVector (Pad a bw),a)) + Dict -> RegisterBank (reverse $ bitCoerce (0 :: BitVector (Pad a bw), a)) -- | Transforms a to _RegisterBank_. -getRegsBe :: forall bw a . (Paddable a, KnownNat bw, 1 <= bw) => a -> RegisterBank bw a 'BigEndian +getRegsBe :: + forall bw a. (Paddable a, KnownNat bw, 1 <= bw) => a -> RegisterBank bw a 'BigEndian getRegsBe a = case timesDivRU @bw @(BitSize a) of - Dict -> RegisterBank (bitCoerce (0 :: BitVector (Pad a bw),a)) + Dict -> RegisterBank (bitCoerce (0 :: BitVector (Pad a bw), a)) -- | Transforms _RegisterBank_ to a. -getDataBe :: forall bw a . (Paddable a, KnownNat bw, 1 <= bw) => RegisterBank bw a 'BigEndian -> a +getDataBe :: + forall bw a. (Paddable a, KnownNat bw, 1 <= bw) => RegisterBank bw a 'BigEndian -> a getDataBe (RegisterBank vec) = case timesDivRU @bw @(BitSize a) of Dict -> unpack . snd $ split @_ @(Pad a bw) @(BitSize a) (pack vec) -- | Transforms _RegisterBank_ to a. -getDataLe :: forall bw a . (Paddable a, KnownNat bw, 1 <= bw) => RegisterBank bw a 'LittleEndian -> a +getDataLe :: + forall bw a. (Paddable a, KnownNat bw, 1 <= bw) => RegisterBank bw a 'LittleEndian -> a getDataLe (RegisterBank (reverse -> vec)) = case timesDivRU @bw @(BitSize a) of Dict -> unpack . snd $ split @_ @(Pad a bw) @(BitSize a) (pack vec) --- | Coerces a tuple of index n and a boolean to index (n*2) where the LSB of the result --- is determined by the boolean. +{- | Coerces a tuple of index n and a boolean to index (n*2) where the LSB of the result +is determined by the boolean. +-} mul2Index :: - forall n b . + forall n b. (KnownNat n, 1 <= n, BitPack b, BitSize b ~ 1) => Index n -> b -> - Index (n*2) -mul2Index n b= case clogProductRule @n of Refl -> bitCoerce (n, b) + Index (n * 2) +mul2Index n b = case clogProductRule @n of Refl -> bitCoerce (n, b) -- | Coerces an index of size (n*2) to index n with the LSB as separate boolean. div2Index :: - forall n b . + forall n b. (KnownNat n, 1 <= n, BitPack b, BitSize b ~ 1) => - Index (n*2) -> + Index (n * 2) -> (Index n, b) div2Index = case clogProductRule @n of Refl -> bitCoerce -- | Delays the output controls to align them with the actual read / write timing. delayControls :: - HiddenClockResetEnable dom => + (HiddenClockResetEnable dom) => Signal dom (WishboneS2M bytes) -> Signal dom (WishboneS2M bytes) delayControls wbIn = wbOut where - delayedAck = register False (acknowledge <$> wbIn) - delayedErr = register False (err <$> wbIn) - wbOut = (\wb newAck newErr-> wb{acknowledge = newAck, err = newErr}) - <$> wbIn <*> delayedAck <*> delayedErr + delayedAck = register False (acknowledge <$> wbIn) + delayedErr = register False (err <$> wbIn) + wbOut = + (\wb newAck newErr -> wb{acknowledge = newAck, err = newErr}) + <$> wbIn + <*> delayedAck + <*> delayedErr -- | Takes an implicit reset and a Signal dom Bool that can force a reset when True. forceReset :: - HiddenReset dom => + (HiddenReset dom) => -- | Forces a reset when True. Signal dom Bool -> -- | Active when the implicit reset is active or the first argument is True. @@ -176,5 +198,5 @@ forceReset :: forceReset force = unsafeFromActiveHigh (unsafeToActiveHigh hasReset .||. force) -- | Divide and round up. -divRU :: Integral a => a -> a -> a +divRU :: (Integral a) => a -> a -> a divRU b a = (b + a - 1) `div` a diff --git a/bittide/src/Bittide/Switch.hs b/bittide/src/Bittide/Switch.hs index d22b2a3a4..b970e53fa 100644 --- a/bittide/src/Bittide/Switch.hs +++ b/bittide/src/Bittide/Switch.hs @@ -15,10 +15,11 @@ import Bittide.Link import Bittide.SharedTypes -- | An index which source is selected by the crossbar, 0 selects Nothing, k selects k - 1. -type CrossbarIndex links = Index (links+1) +type CrossbarIndex links = Index (links + 1) --- | Stores for each link, an index where the incoming frame is written to in the scatter --- memory and a crossbar index to select the outgoing frame. +{- | Stores for each link, an index where the incoming frame is written to in the scatter +memory and a crossbar index to select the outgoing frame. +-} type CalendarEntry links = Vec links (CrossbarIndex links) data SwitchConfig links nBytes addrW where @@ -26,48 +27,60 @@ data SwitchConfig links nBytes addrW where (KnownNat preambleWidth, 1 <= preambleWidth, 1 <= nBytes, 2 <= addrW) => { preamble :: BitVector preambleWidth , calendarConfig :: CalendarConfig nBytes addrW (CalendarEntry links) - } - -> SwitchConfig links nBytes addrW + } -> + SwitchConfig links nBytes addrW deriving instance Show (SwitchConfig links nBytes addrW) --- | Creates a 'switch' from a 'SwitchConfig'. This wrapper functions hides the @preambleWidth@ --- type variable from the rest of the implementation. For more documentation see 'switch'. +{- | Creates a 'switch' from a 'SwitchConfig'. This wrapper functions hides the @preambleWidth@ +type variable from the rest of the implementation. For more documentation see 'switch'. +-} mkSwitch :: ( HiddenClockResetEnable dom , KnownNat links - , KnownNat frameWidth, 1 <= frameWidth - , KnownNat nBytes, 1 <= nBytes - , KnownNat addrW, 2 <= addrW) => + , KnownNat frameWidth + , 1 <= frameWidth + , KnownNat nBytes + , 1 <= nBytes + , KnownNat addrW + , 2 <= addrW + ) => SwitchConfig links nBytes addrW -> Signal dom (WishboneM2S addrW nBytes (Bytes nBytes)) -> Vec links (Signal dom (WishboneM2S addrW nBytes (Bytes nBytes))) -> Vec links (Signal dom (WishboneM2S addrW nBytes (Bytes nBytes))) -> Vec links (Signal dom (DataLink frameWidth)) -> ( Vec links (Signal dom (DataLink frameWidth)) - , Vec (1 + (links * 2)) (Signal dom (WishboneS2M (Bytes nBytes)))) - + , Vec (1 + (links * 2)) (Signal dom (WishboneS2M (Bytes nBytes))) + ) mkSwitch SwitchConfig{..} = switch preamble calendarConfig {-# NOINLINE switch #-} + -- TODO: The switch is currently hardcoded to be bidirectional, we intend to change this when -- the need arises. --- | The Bittide Switch routes data from incoming links to outgoing links based on a 'Calendar'. --- The switch consists of a 'crossbar', a 'calendar' and receiver and transmitter logic per link. --- The receive logic consists of a 'rxUnit' and a receive register (single depth --- 'Bittide.ScatterGather.scatterUnit'). The transmit logic consists of a transmit register --- (single depth 'Bittide.ScatterGather.gatherUnit') and a 'txUnit'. The 'crossbar' selects --- one of the receive register's output for each transmit register. Index @0@ selects a --- null frame @Nothing@ and @k@ selects receive register @(k - 1)@. +{- | The Bittide Switch routes data from incoming links to outgoing links based on a 'Calendar'. +The switch consists of a 'crossbar', a 'calendar' and receiver and transmitter logic per link. +The receive logic consists of a 'rxUnit' and a receive register (single depth +'Bittide.ScatterGather.scatterUnit'). The transmit logic consists of a transmit register +(single depth 'Bittide.ScatterGather.gatherUnit') and a 'txUnit'. The 'crossbar' selects +one of the receive register's output for each transmit register. Index @0@ selects a +null frame @Nothing@ and @k@ selects receive register @(k - 1)@. +-} switch :: - forall dom nBytes addrW links frameWidth preambleWidth . + forall dom nBytes addrW links frameWidth preambleWidth. ( HiddenClockResetEnable dom - , KnownNat addrW, 2 <= addrW - , KnownNat frameWidth, 1 <= frameWidth + , KnownNat addrW + , 2 <= addrW + , KnownNat frameWidth + , 1 <= frameWidth , KnownNat links - , KnownNat nBytes, 1 <= nBytes - , KnownNat preambleWidth, 1 <= preambleWidth) => + , KnownNat nBytes + , 1 <= nBytes + , KnownNat preambleWidth + , 1 <= preambleWidth + ) => -- | Preamble for Bittide links. BitVector preambleWidth -> -- | The calendar configuration @@ -81,23 +94,26 @@ switch :: -- | All incoming datalinks Vec links (Signal dom (DataLink frameWidth)) -> -- | All outgoing datalinks - ( Vec links (Signal dom (DataLink frameWidth)) - , Vec (1 + (2 * links)) (Signal dom (WishboneS2M (Bytes nBytes)))) + ( Vec links (Signal dom (DataLink frameWidth)) + , Vec (1 + (2 * links)) (Signal dom (WishboneS2M (Bytes nBytes))) + ) switch preamble calConfig calM2S rxM2Ss txM2Ss streamsIn = - (streamsOut,calS2M :> (rxS2Ms ++ txS2Ms)) - where - (cal, _, calS2M) = mkCalendar calConfig calM2S - rxS2Ms = rxUnit preamble sequenceCounter <$> streamsIn <*> rxM2Ss - scatterFrames = register Nothing <$> streamsIn - crossBarOut = unbundle $ crossBar <$> cal <*> bundle scatterFrames - gatherFrames = register Nothing <$> crossBarOut - (txS2Ms, streamsOut) = unzip $ txUnit preamble sequenceCounter <$> gatherFrames <*> txM2Ss + (streamsOut, calS2M :> (rxS2Ms ++ txS2Ms)) + where + (cal, _, calS2M) = mkCalendar calConfig calM2S + rxS2Ms = rxUnit preamble sequenceCounter <$> streamsIn <*> rxM2Ss + scatterFrames = register Nothing <$> streamsIn + crossBarOut = unbundle $ crossBar <$> cal <*> bundle scatterFrames + gatherFrames = register Nothing <$> crossBarOut + (txS2Ms, streamsOut) = unzip $ txUnit preamble sequenceCounter <$> gatherFrames <*> txM2Ss {-# NOINLINE crossBar #-} --- | The 'crossbar' receives a vector of indices and a vector of incoming frames. --- For each outgoing link it will select a data source. @0@ selects a null frame @Nothing@, --- therefore indexing of incoming links starts at 1 (index 1 selects incoming frame 0). --- Source: bittide hardware, switch logic. + +{- | The 'crossbar' receives a vector of indices and a vector of incoming frames. +For each outgoing link it will select a data source. @0@ selects a null frame @Nothing@, +therefore indexing of incoming links starts at 1 (index 1 selects incoming frame 0). +Source: bittide hardware, switch logic. +-} crossBar :: (KnownNat links) => Vec links (CrossbarIndex links) -> diff --git a/bittide/src/Bittide/Transceiver.hs b/bittide/src/Bittide/Transceiver.hs index 131d89f79..afb817628 100644 --- a/bittide/src/Bittide/Transceiver.hs +++ b/bittide/src/Bittide/Transceiver.hs @@ -1,90 +1,88 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE OverloadedRecordDot #-} - +{-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} --- | Transceiver module for the Bittide project. This module is a wrapper around --- the 'Clash.Cores.Xilinx.GTH.gthCore' function, adding additional functionality --- such as PRBS generation and checking, comma insertion, word alignment, and --- user data handshaking. --- --- __CAUTION__: When instantiating multiple transceivers you might want to use --- 'transceiverPrbsN'. Make sure to read its documentation before proceeding. --- --- = Internals --- This section will cover the internals of the transceiver module. Feel free to --- skip reading this if you just want to use the transceiver. --- --- __Commas__ --- We've configured the Xilinx transceiver IP to use 8b/10b encoding. In order --- for the decoding to work properly, the transceivers need to byte-align. This --- is done by detecting comma symbols in the incoming data stream. We start out --- by sending them for a number of cycles (see @Comma.@'Comma.defCycles'). --- --- __Word alignment__ --- After sending commas, we assume the receiver receives our words in a byte-aligned --- fashion. We can use this fact by reserving the MSB of each byte for an alignment --- symbol - see "Bittide.Transceiver.WordAlign". --- --- __Meta data__ --- We send along meta data with each word. This meta data is used to signal to the --- neighbor that we're ready to receive user data, or that the next word will be --- user data. The meta data also contains the FPGA and transceiver index, which --- can be used for debugging. --- --- __Reset manager__ --- A reset manager is used as a sort of \"watchdog\" while booting the --- transceivers. It will reset the receive side of the transceiver if it doesn't --- receive sensible (PRBS) data for a certain amount of time. After resetting the --- receive side for a number of times, it will reset the transmit side as well if --- the received data is still considered gibberish. Note that this means that if --- you receive *good* data for @'Bittide.Transceiver.ResetManager.rxRetries' * --- 'Bittide.Transceiver.ResetManager.rxTimeoutMs'@ milliseconds, you can be sure --- the neighbor won't reset its transceiver anymore. --- --- __Word format__ --- An (aligned) 64 bit word is formatted as follows: --- --- > +----------+----------+----------+----------+----------+----------+----------+----------+ --- > | 1mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | --- > +----------+----------+----------+----------+----------+----------+----------+----------+ --- --- * 1/0: alignment symbol --- * m: meta data --- * p: PRBS data --- --- __Protocol__ --- The protocol is as follows: --- --- Transmit: --- --- 1. Send commas for a number of cycles --- 2. Send PRBS data with meta data --- 3. Wait for receiver to signal it has successfully decoded PRBS data for a long time --- 4. Send meta data with 'ready' set to 'True' --- 5. Wait for 'Input.txReady' --- 6. Send meta data with 'lastPrbsWord' set to 'True' --- 7. Send user data --- --- Note that the reset manager might decide to reset in steps (2) and (3). --- --- Receive: --- --- 1. Detect alignment symbol and shift data accordingly --- 2. Check PRBS data --- 3. Signal that PRBS data is OK after observing it for some time (see section --- __Reset manager__). --- 4. Wait for 'Meta.lastPrbsWord' --- 5. Freeze alignment logic --- +{- | Transceiver module for the Bittide project. This module is a wrapper around +the 'Clash.Cores.Xilinx.GTH.gthCore' function, adding additional functionality +such as PRBS generation and checking, comma insertion, word alignment, and +user data handshaking. + +__CAUTION__: When instantiating multiple transceivers you might want to use +'transceiverPrbsN'. Make sure to read its documentation before proceeding. + += Internals +This section will cover the internals of the transceiver module. Feel free to +skip reading this if you just want to use the transceiver. + +__Commas__ +We've configured the Xilinx transceiver IP to use 8b/10b encoding. In order +for the decoding to work properly, the transceivers need to byte-align. This +is done by detecting comma symbols in the incoming data stream. We start out +by sending them for a number of cycles (see @Comma.@'Comma.defCycles'). + +__Word alignment__ +After sending commas, we assume the receiver receives our words in a byte-aligned +fashion. We can use this fact by reserving the MSB of each byte for an alignment +symbol - see "Bittide.Transceiver.WordAlign". + +__Meta data__ +We send along meta data with each word. This meta data is used to signal to the +neighbor that we're ready to receive user data, or that the next word will be +user data. The meta data also contains the FPGA and transceiver index, which +can be used for debugging. + +__Reset manager__ +A reset manager is used as a sort of \"watchdog\" while booting the +transceivers. It will reset the receive side of the transceiver if it doesn't +receive sensible (PRBS) data for a certain amount of time. After resetting the +receive side for a number of times, it will reset the transmit side as well if +the received data is still considered gibberish. Note that this means that if +you receive *good* data for @'Bittide.Transceiver.ResetManager.rxRetries' * +'Bittide.Transceiver.ResetManager.rxTimeoutMs'@ milliseconds, you can be sure +the neighbor won't reset its transceiver anymore. + +__Word format__ +An (aligned) 64 bit word is formatted as follows: + +> +----------+----------+----------+----------+----------+----------+----------+----------+ +> | 1mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | 0mpppppp | +> +----------+----------+----------+----------+----------+----------+----------+----------+ + + * 1/0: alignment symbol + * m: meta data + * p: PRBS data + +__Protocol__ +The protocol is as follows: + +Transmit: + + 1. Send commas for a number of cycles + 2. Send PRBS data with meta data + 3. Wait for receiver to signal it has successfully decoded PRBS data for a long time + 4. Send meta data with 'ready' set to 'True' + 5. Wait for 'Input.txReady' + 6. Send meta data with 'lastPrbsWord' set to 'True' + 7. Send user data + +Note that the reset manager might decide to reset in steps (2) and (3). + +Receive: + + 1. Detect alignment symbol and shift data accordingly + 2. Check PRBS data + 3. Signal that PRBS data is OK after observing it for some time (see section + __Reset manager__). + 4. Wait for 'Meta.lastPrbsWord' + 5. Freeze alignment logic +-} module Bittide.Transceiver where import Clash.Explicit.Prelude @@ -92,15 +90,20 @@ import Clash.Explicit.Prelude import Bittide.Arithmetic.Time (trueForSteps) import Bittide.ElasticBuffer (sticky) import Clash.Cores.Xilinx.GTH (GthCore) -import Clash.Cores.Xilinx.Ila (IlaConfig(advancedTriggers, depth, stages), ilaConfig, ila, Depth(D1024)) +import Clash.Cores.Xilinx.Ila ( + Depth (D1024), + IlaConfig (advancedTriggers, depth, stages), + ila, + ilaConfig, + ) import Clash.Cores.Xilinx.Xpm.Cdc.ArraySingle (xpmCdcArraySingle) import Clash.Cores.Xilinx.Xpm.Cdc.Single (xpmCdcSingle) -import Clash.Explicit.Reset.Extra (Asserted(Asserted), delayReset, xpmResetSynchronizer) +import Clash.Explicit.Reset.Extra (Asserted (Asserted), delayReset, xpmResetSynchronizer) import Clash.Prelude (withClock) import Clash.Sized.Vector.Extra (zipWith8) import Control.Monad (when) -import Data.Maybe (isNothing, fromMaybe) -import Data.Proxy (Proxy(Proxy)) +import Data.Maybe (fromMaybe, isNothing) +import Data.Proxy (Proxy (Proxy)) import qualified Bittide.Transceiver.Cdc as Cdc import qualified Bittide.Transceiver.Comma as Comma @@ -109,8 +112,9 @@ import qualified Bittide.Transceiver.ResetManager as ResetManager import qualified Bittide.Transceiver.WordAlign as WordAlign import qualified Clash.Cores.Xilinx.GTH as Gth --- | Meta information send along with the PRBS and alignment symbols. See module --- documentation for more information. +{- | Meta information send along with the PRBS and alignment symbols. See module +documentation for more information. +-} data Meta = Meta { ready :: Bool -- ^ Ready to receive user data @@ -123,23 +127,29 @@ data Meta = Meta } deriving (Generic, NFDataX, BitPack) --- | Insert zeroes such that each of the following are encoded in 4 bits, making --- them easier to read when formatted as a hex value: --- --- * prbsOk, lastPrbsWord --- * fpgaIndex --- * transceiverIndex --- --- This is useful for when we don't control formatting (such as when looking at --- ILA traces). +{- | Insert zeroes such that each of the following are encoded in 4 bits, making +them easier to read when formatted as a hex value: + + * prbsOk, lastPrbsWord + * fpgaIndex + * transceiverIndex + +This is useful for when we don't control formatting (such as when looking at +ILA traces). +-} prettifyMetaBits :: BitVector 8 -> BitVector 12 -prettifyMetaBits bv = pack $ - let meta = unpack @Meta bv in - ( low, low, meta.ready - , meta.lastPrbsWord - , low, meta.fpgaIndex - , low, meta.transceiverIndex - ) +prettifyMetaBits bv = + pack + $ let meta = unpack @Meta bv + in ( low + , low + , meta.ready + , meta.lastPrbsWord + , low + , meta.fpgaIndex + , low + , meta.transceiverIndex + ) data Config dom = Config { debugIla :: Bool @@ -151,14 +161,16 @@ data Config dom = Config } defConfig :: Config dom -defConfig = Config - { debugIla = False - , debugFpgaIndex = pure 0 - , resetManagerConfig = ResetManager.defConfig - } +defConfig = + Config + { debugIla = False + , debugFpgaIndex = pure 0 + , resetManagerConfig = ResetManager.defConfig + } --- | Careful: the domains for each transceiver are different, even if their --- types say otherwise. +{- | Careful: the domains for each transceiver are different, even if their +types say otherwise. +-} data Outputs n tx rx txS free = Outputs { txClocks :: Vec n (Clock tx) -- ^ See 'Output.txClock' @@ -168,19 +180,16 @@ data Outputs n tx rx txS free = Outputs -- ^ See 'Output.txReady' , txSamplings :: Vec n (Signal tx Bool) -- ^ See 'Output.txSampling' - , txPs :: Signal txS (BitVector n) -- ^ See 'Output.txP' , txNs :: Signal txS (BitVector n) -- ^ See 'Output.txN' - , rxClocks :: Vec n (Clock rx) -- ^ See 'Output.rxClock' , rxResets :: Vec n (Reset rx) -- ^ See 'Output.rxReset' , rxDatas :: Vec n (Signal rx (Maybe (BitVector 64))) -- ^ See 'Output.rxData' - , linkUps :: Vec n (Signal free Bool) -- ^ See 'Output.linkUp' , linkReadys :: Vec n (Signal free Bool) @@ -200,12 +209,10 @@ data Output tx rx txS free serializedData = Output -- 'Input.txReady' to be asserted before starting to send 'txData'. , txSampling :: Signal tx Bool -- ^ Data is sampled from 'Input.txSampling' - , txP :: Signal txS serializedData -- ^ Transmit data (and implicitly a clock), positive , txN :: Signal txS serializedData -- ^ Transmit data (and implicitly a clock), negative - , rxClock :: Clock rx -- ^ Receive clock, recovered from the incoming data stream. See 'rxReset'. , rxReset :: Reset rx @@ -213,7 +220,6 @@ data Output tx rx txS free serializedData = Output -- is deasserted. , rxData :: Signal rx (Maybe (BitVector 64)) -- ^ User data received from the neighbor - , linkUp :: Signal free Bool -- ^ True if both the transmit and receive side are either handling user data , linkReady :: Signal free Bool @@ -230,17 +236,14 @@ data Input tx rx ref free rxS serializedData = Input -- ^ Reset signal for the entire transceiver , refClock :: Clock ref -- ^ Reference clock. Used to synthesize transmit clock. - , transceiverIndex :: Unsigned 3 -- ^ Index of this transceiver, used for debugging. Can be set to 0 if not used. , channelName :: String -- ^ Channel name, example \"X0Y18\" , clockPath :: String -- ^ Clock path, example \"clk0-2\" - , rxN :: Signal rxS serializedData , rxP :: Signal rxS serializedData - , txData :: Signal tx (BitVector 64) -- ^ Data to transmit to the neighbor. Is sampled on sample after -- 'Output.txSamplingOnNext' is asserted. Is sampled when @@ -279,19 +282,15 @@ data Inputs tx rx ref free rxS n = Inputs -- ^ See 'Input.rxReady' } - transceiverPrbsN :: - forall tx rx ref free txS rxS n . + forall tx rx ref free txS rxS n. ( KnownNat n , HasSynchronousReset tx , HasDefinedInitialValues tx - , HasSynchronousReset rx , HasDefinedInitialValues rx - , HasSynchronousReset free , HasDefinedInitialValues free - , KnownDomain rxS , KnownDomain txS , KnownDomain ref @@ -300,27 +299,25 @@ transceiverPrbsN :: Config free -> Inputs tx rx ref free rxS n -> Outputs n tx rx txS free -transceiverPrbsN opts inputs@Inputs{clock, reset, refClock} = Outputs - -- tx - { txClocks = map (.txClock) outputs - , txResets = map (.txReset) outputs - , txReadys = map (.txReady) outputs - , txSamplings = map (.txSampling) outputs - - -- rx - , rxClocks = map (.rxClock) outputs - , rxResets = map (.rxReset) outputs - , rxDatas = map (.rxData) outputs - - -- transceiver - , txPs = pack <$> bundle (map (.txP) outputs) - , txNs = pack <$> bundle (map (.txN) outputs) - - -- free - , linkUps = map (.linkUp) outputs - , linkReadys = map (.linkReady) outputs - , stats = map (.stats) outputs - } +transceiverPrbsN opts inputs@Inputs{clock, reset, refClock} = + Outputs + { -- tx + txClocks = map (.txClock) outputs + , txResets = map (.txReset) outputs + , txReadys = map (.txReady) outputs + , txSamplings = map (.txSampling) outputs + , -- rx + rxClocks = map (.rxClock) outputs + , rxResets = map (.rxReset) outputs + , rxDatas = map (.rxData) outputs + , -- transceiver + txPs = pack <$> bundle (map (.txP) outputs) + , txNs = pack <$> bundle (map (.txN) outputs) + , -- free + linkUps = map (.linkUp) outputs + , linkReadys = map (.linkReady) outputs + , stats = map (.stats) outputs + } where -- XXX: Replacing 'zipWithN' with '<$>' and '<*>' triggers a combination of: -- @@ -328,35 +325,45 @@ transceiverPrbsN opts inputs@Inputs{clock, reset, refClock} = Outputs -- * https://github.com/clash-lang/clash-compiler/issues/2722 -- -- Note that these bugs break the instantiation of multiple ILAs. - outputs = zipWith8 go - (iterateI (+1) 0) -- Note that the target type is only 3 bits, so this will - -- wrap around after 8 transceivers. This is fine, as we - -- only use this for debugging. - inputs.channelNames - inputs.clockPaths - (unbundle (unpack <$> inputs.rxNs)) - (unbundle (unpack <$> inputs.rxPs)) - inputs.txDatas - inputs.txReadys - inputs.rxReadys + outputs = + zipWith8 + go + (iterateI (+ 1) 0) -- Note that the target type is only 3 bits, so this will + -- wrap around after 8 transceivers. This is fine, as we + -- only use this for debugging. + inputs.channelNames + inputs.clockPaths + (unbundle (unpack <$> inputs.rxNs)) + (unbundle (unpack <$> inputs.rxPs)) + inputs.txDatas + inputs.txReadys + inputs.rxReadys go transceiverIndex channelName clockPath rxN rxP txData txReady rxReady = - transceiverPrbs opts Input - { channelName, clockPath, rxN, rxP, txData, txReady, rxReady, transceiverIndex - , clock, reset, refClock - } + transceiverPrbs + opts + Input + { channelName + , clockPath + , rxN + , rxP + , txData + , txReady + , rxReady + , transceiverIndex + , clock + , reset + , refClock + } transceiverPrbs :: - forall tx rx ref free txS rxS . + forall tx rx ref free txS rxS. ( HasSynchronousReset tx , HasDefinedInitialValues tx - , HasSynchronousReset rx , HasDefinedInitialValues rx - , HasSynchronousReset free , HasDefinedInitialValues free - , KnownDomain rxS , KnownDomain txS , KnownDomain ref @@ -368,16 +375,13 @@ transceiverPrbs :: transceiverPrbs = transceiverPrbsWith Gth.gthCore transceiverPrbsWith :: - forall tx rx ref free txS rxS serializedData . + forall tx rx ref free txS rxS serializedData. ( HasSynchronousReset tx , HasDefinedInitialValues tx - , HasSynchronousReset rx , HasDefinedInitialValues rx - , HasSynchronousReset free , HasDefinedInitialValues free - , KnownDomain rxS , KnownDomain txS , KnownDomain ref @@ -390,110 +394,129 @@ transceiverPrbsWith :: transceiverPrbsWith gthCore opts args@Input{clock, reset} = when opts.debugIla debugIla `hwSeqX` result where - debugIla :: Signal free () - debugIla = ila - ((ilaConfig $ - "ila_probe_fpgaIndex" - :> "ila_probe_transIndex" - :> "ila_probe_txRetries" - :> "ila_probe_rxRetries" - :> "ila_probe_rxFullRetries" - :> "ila_probe_failAfterUps" - :> "ila_probe_rx_data0" - :> "ila_probe_alignedRxData0" - :> "ila_probe_gtwiz_userdata_tx_in" - :> "ila_probe_reset_rx_done" - :> "ila_probe_reset_tx_done" - :> "ila_probe_reset" - :> "ila_probe_alignError" - :> "ila_probe_prbsErrors" - :> "ila_probe_alignedAlignBits" - :> "ila_probe_alignedMetaBits" - :> "ila_probe_rxCtrl0" - :> "ila_probe_rxCtrl1" - :> "ila_probe_rxCtrl2" - :> "ila_probe_rxCtrl3" - :> "ila_probe_prbsOk" - :> "ila_probe_prbsOkDelayed" - :> "ila_probe_rst_all" - :> "ila_probe_rst_rx" - :> "ila_probe_rxReset" - :> "ila_probe_txReset" - :> "ila_probe_metaTx" - :> "ila_probe_linkUp" - :> "ila_probe_txLastFree" - :> "capture" - :> "trigger" - :> Nil) { advancedTriggers = True, stages = 1, depth = D1024 }) - clock - opts.debugFpgaIndex - (pure args.transceiverIndex :: Signal free (Unsigned 3)) - ((.txRetries) <$> stats) - ((.rxRetries) <$> stats) - ((.rxFullRetries) <$> stats) - ((.failAfterUps) <$> stats) - (xpmCdcArraySingle rxClock clock rx_data0) - (xpmCdcArraySingle rxClock clock alignedRxData0) - (xpmCdcArraySingle txClock clock gtwiz_userdata_tx_in) - (xpmCdcArraySingle rxClock clock reset_rx_done) - (xpmCdcArraySingle txClock clock reset_tx_done) - (unsafeToActiveHigh reset) - (xpmCdcArraySingle rxClock clock alignError) - (xpmCdcArraySingle rxClock clock prbsErrors) - (xpmCdcArraySingle rxClock clock alignedAlignBits) - (xpmCdcArraySingle rxClock clock (prettifyMetaBits <$> alignedMetaBits)) - (xpmCdcArraySingle rxClock clock rxCtrl0) - (xpmCdcArraySingle rxClock clock rxCtrl1) - (xpmCdcArraySingle rxClock clock rxCtrl2) - (xpmCdcArraySingle rxClock clock rxCtrl3) - (xpmCdcSingle rxClock clock prbsOk) - (xpmCdcSingle rxClock clock prbsOkDelayed) - (unsafeToActiveHigh rst_all) - (unsafeToActiveHigh rst_rx) - (xpmCdcSingle rxClock clock $ unsafeToActiveHigh rxReset) - (xpmCdcSingle txClock clock $ unsafeToActiveHigh txReset) - (xpmCdcArraySingle txClock clock (prettifyMetaBits . pack <$> metaTx)) - linkUp - txLastFree - (pure True :: Signal free Bool) -- capture - txLastFree -- trigger - - result = Output - { txSampling = txUserData - , rxData = mux rxUserData (Just <$> alignedRxData0) (pure Nothing) - , txReady - , txN, txP - , txClock - , txReset - , rxClock - , rxReset - , linkUp - , linkReady - , stats - } + debugIla = + ila + ( ( ilaConfig + $ "ila_probe_fpgaIndex" + :> "ila_probe_transIndex" + :> "ila_probe_txRetries" + :> "ila_probe_rxRetries" + :> "ila_probe_rxFullRetries" + :> "ila_probe_failAfterUps" + :> "ila_probe_rx_data0" + :> "ila_probe_alignedRxData0" + :> "ila_probe_gtwiz_userdata_tx_in" + :> "ila_probe_reset_rx_done" + :> "ila_probe_reset_tx_done" + :> "ila_probe_reset" + :> "ila_probe_alignError" + :> "ila_probe_prbsErrors" + :> "ila_probe_alignedAlignBits" + :> "ila_probe_alignedMetaBits" + :> "ila_probe_rxCtrl0" + :> "ila_probe_rxCtrl1" + :> "ila_probe_rxCtrl2" + :> "ila_probe_rxCtrl3" + :> "ila_probe_prbsOk" + :> "ila_probe_prbsOkDelayed" + :> "ila_probe_rst_all" + :> "ila_probe_rst_rx" + :> "ila_probe_rxReset" + :> "ila_probe_txReset" + :> "ila_probe_metaTx" + :> "ila_probe_linkUp" + :> "ila_probe_txLastFree" + :> "capture" + :> "trigger" + :> Nil + ) + { advancedTriggers = True + , stages = 1 + , depth = D1024 + } + ) + clock + opts.debugFpgaIndex + (pure args.transceiverIndex :: Signal free (Unsigned 3)) + ((.txRetries) <$> stats) + ((.rxRetries) <$> stats) + ((.rxFullRetries) <$> stats) + ((.failAfterUps) <$> stats) + (xpmCdcArraySingle rxClock clock rx_data0) + (xpmCdcArraySingle rxClock clock alignedRxData0) + (xpmCdcArraySingle txClock clock gtwiz_userdata_tx_in) + (xpmCdcArraySingle rxClock clock reset_rx_done) + (xpmCdcArraySingle txClock clock reset_tx_done) + (unsafeToActiveHigh reset) + (xpmCdcArraySingle rxClock clock alignError) + (xpmCdcArraySingle rxClock clock prbsErrors) + (xpmCdcArraySingle rxClock clock alignedAlignBits) + (xpmCdcArraySingle rxClock clock (prettifyMetaBits <$> alignedMetaBits)) + (xpmCdcArraySingle rxClock clock rxCtrl0) + (xpmCdcArraySingle rxClock clock rxCtrl1) + (xpmCdcArraySingle rxClock clock rxCtrl2) + (xpmCdcArraySingle rxClock clock rxCtrl3) + (xpmCdcSingle rxClock clock prbsOk) + (xpmCdcSingle rxClock clock prbsOkDelayed) + (unsafeToActiveHigh rst_all) + (unsafeToActiveHigh rst_rx) + (xpmCdcSingle rxClock clock $ unsafeToActiveHigh rxReset) + (xpmCdcSingle txClock clock $ unsafeToActiveHigh txReset) + (xpmCdcArraySingle txClock clock (prettifyMetaBits . pack <$> metaTx)) + linkUp + txLastFree + (pure True :: Signal free Bool) -- capture + txLastFree -- trigger + result = + Output + { txSampling = txUserData + , rxData = mux rxUserData (Just <$> alignedRxData0) (pure Nothing) + , txReady + , txN + , txP + , txClock + , txReset + , rxClock + , rxReset + , linkUp + , linkReady + , stats + } linkUp = - withLockTxFree txUserData - .&&. withLockRxFree rxUserData + withLockTxFree txUserData + .&&. withLockRxFree rxUserData linkReady = linkUp .||. withLockRxFree rxReadySticky - ( txN, txP, txClock, rxClock, rx_data0, reset_tx_done, reset_rx_done, tx_active - , rxCtrl0, rxCtrl1, rxCtrl2, rxCtrl3 ) - = gthCore - args.channelName args.clockPath + ( txN + , txP + , txClock + , rxClock + , rx_data0 + , reset_tx_done + , reset_rx_done + , tx_active + , rxCtrl0 + , rxCtrl1 + , rxCtrl2 + , rxCtrl3 + ) = + gthCore + args.channelName + args.clockPath args.rxN args.rxP - clock -- gtwiz_reset_clk_freerun_in - - (delayReset Asserted clock rst_all {-* filter glitches *-}) - (delayReset Asserted clock rst_rx {-* filter glitches *-}) -- gtwiz_reset_rx_datapath_in + (delayReset Asserted clock rst_all) + -- \* filter glitches * + (delayReset Asserted clock rst_rx) + -- \* filter glitches * + -- gtwiz_reset_rx_datapath_in gtwiz_userdata_tx_in txctrl args.refClock -- gtrefclk0_in - prbsConfig = Prbs.conf31 @48 (commas, txctrl) = Comma.generator d1 txClock txReset @@ -508,19 +531,24 @@ transceiverPrbsWith gthCore opts args@Input{clock, reset} = (fromMaybe <$> prbsWithMetaAndAlign <*> commas) rxReset = - xpmResetSynchronizer Asserted rxClock rxClock $ - unsafeFromActiveLow (bitCoerce <$> reset_rx_done) + xpmResetSynchronizer Asserted rxClock rxClock + $ unsafeFromActiveLow (bitCoerce <$> reset_rx_done) `orReset` xpmResetSynchronizer Asserted clock rxClock reset alignedRxData0 :: Signal rx (BitVector 64) - alignedRxData0 = withClock rxClock $ - WordAlign.alignBytesFromMsbs @8 WordAlign.alignLsbFirst (rxUserData .||. rxLast) rx_data0 + alignedRxData0 = + withClock rxClock + $ WordAlign.alignBytesFromMsbs @8 WordAlign.alignLsbFirst (rxUserData .||. rxLast) rx_data0 - (alignedAlignBits, alignedRxData1) = unbundle $ - WordAlign.splitMsbs @8 @8 <$> alignedRxData0 + (alignedAlignBits, alignedRxData1) = + unbundle + $ WordAlign.splitMsbs @8 @8 + <$> alignedRxData0 - (alignedMetaBits, alignedRxData2) = unbundle $ - WordAlign.splitMsbs @8 @7 <$> alignedRxData1 + (alignedMetaBits, alignedRxData2) = + unbundle + $ WordAlign.splitMsbs @8 @7 + <$> alignedRxData1 prbsErrors = Prbs.checker rxClock rxReset enableGen prbsConfig alignedRxData2 anyPrbsErrors = prbsErrors ./=. pure 0 @@ -532,22 +560,26 @@ transceiverPrbsWith gthCore opts args@Input{clock, reset} = -- -- TODO: Truncate rxCtrl0 and rxCtrl1 in GTH primitive. rxCtrlOrError = - fmap (truncateB @_ @8) rxCtrl0 ./=. pure 0 - .||. fmap (truncateB @_ @8) rxCtrl1 ./=. pure 0 - .||. rxCtrl2 ./=. pure 0 - .||. rxCtrl3 ./=. pure 0 + fmap (truncateB @_ @8) rxCtrl0 + ./=. pure 0 + .||. fmap (truncateB @_ @8) rxCtrl1 + ./=. pure 0 + .||. rxCtrl2 + ./=. pure 0 + .||. rxCtrl3 + ./=. pure 0 prbsOk = - rxUserData - .||. Prbs.tracker rxClock rxReset (anyPrbsErrors .||. alignError .||. rxCtrlOrError) + rxUserData + .||. Prbs.tracker rxClock rxReset (anyPrbsErrors .||. alignError .||. rxCtrlOrError) -- 'prbsWaitMs' is the number of milliseconds representing the worst case time -- it takes for the PRBS to stabilize. I.e., after this time we can be sure the -- neighbor doesn't reset its transceiver anymore. We add a single retry to -- account for clock speed variations. prbsWaitMs = - ((1 :: Index 2) `add` opts.resetManagerConfig.rxRetries) - `mul` opts.resetManagerConfig.rxTimeoutMs + ((1 :: Index 2) `add` opts.resetManagerConfig.rxRetries) + `mul` opts.resetManagerConfig.rxTimeoutMs prbsOkDelayed = trueForSteps (Proxy @(Milliseconds 1)) prbsWaitMs rxClock rxReset prbsOk validMeta = mux rxUserData (pure False) prbsOkDelayed @@ -565,28 +597,31 @@ transceiverPrbsWith gthCore opts args@Input{clock, reset} = txLastFree = xpmCdcSingle txClock clock txLast metaTx :: Signal tx Meta - metaTx = Meta - <$> txReady - <*> txLast - -- We shouldn't sync with 'xpmCdcArraySingle' here, as the individual bits in - -- 'fpgaIndex' are related to each other. Still, we know fpgaIndex is basically - -- a constant so :shrug:. - <*> xpmCdcArraySingle clock txClock opts.debugFpgaIndex - <*> pure args.transceiverIndex + metaTx = + Meta + <$> txReady + <*> txLast + -- We shouldn't sync with 'xpmCdcArraySingle' here, as the individual bits in + -- 'fpgaIndex' are related to each other. Still, we know fpgaIndex is basically + -- a constant so :shrug:. + <*> xpmCdcArraySingle clock txClock opts.debugFpgaIndex + <*> pure args.transceiverIndex (rst_all, rst_rx, stats) = ResetManager.resetManager opts.resetManagerConfig - clock reset + clock + reset (withLockTxFree (pure True)) (withLockRxFree (pure True)) (withLockRxFree (prbsOk .||. rxUserData)) - txReset = xpmResetSynchronizer Asserted txClock txClock $ - unsafeFromActiveLow (bitCoerce <$> tx_active) - `orReset` unsafeFromActiveLow (bitCoerce <$> reset_tx_done) - `orReset` xpmResetSynchronizer Asserted clock txClock reset + txReset = + xpmResetSynchronizer Asserted txClock txClock + $ unsafeFromActiveLow (bitCoerce <$> tx_active) + `orReset` unsafeFromActiveLow (bitCoerce <$> reset_tx_done) + `orReset` xpmResetSynchronizer Asserted clock txClock reset withLockTxFree = Cdc.withLock txClock (unpack <$> reset_tx_done) clock reset withLockRxFree = Cdc.withLock rxClock (unpack <$> reset_rx_done) clock reset - withLockRxTx = Cdc.withLock rxClock (unpack <$> reset_rx_done) txClock txReset + withLockRxTx = Cdc.withLock rxClock (unpack <$> reset_rx_done) txClock txReset diff --git a/bittide/src/Bittide/Transceiver/Cdc.hs b/bittide/src/Bittide/Transceiver/Cdc.hs index 48bbc062e..2d7a91c32 100644 --- a/bittide/src/Bittide/Transceiver/Cdc.hs +++ b/bittide/src/Bittide/Transceiver/Cdc.hs @@ -2,36 +2,44 @@ -- -- SPDX-License-Identifier: Apache-2.0 --- | Utilities to safely synchronize signals between different clock domains, --- where either the source or the destination clock is inactive. +{- | Utilities to safely synchronize signals between different clock domains, +where either the source or the destination clock is inactive. +-} module Bittide.Transceiver.Cdc (withLock) where import Clash.Explicit.Prelude -import Clash.Cores.Xilinx.Xpm.Cdc.Single (XpmCdcSingleConfig(..), xpmCdcSingleWith) +import Clash.Cores.Xilinx.Xpm.Cdc.Single (XpmCdcSingleConfig (..), xpmCdcSingleWith) --- | Synchronize an (asynchronous) lock signal between two clock domains. This is --- different from using 'xpmCdcSingle' directly, as it ensures that the registers --- in the destination domain are properly reset. +{- | Synchronize an (asynchronous) lock signal between two clock domains. This is +different from using 'xpmCdcSingle' directly, as it ensures that the registers +in the destination domain are properly reset. +-} withLock :: ( KnownDomain src - , KnownDomain dst ) => - Clock src -> Signal src Bool -> - Clock dst -> Reset dst -> + , KnownDomain dst + ) => + Clock src -> + Signal src Bool -> + Clock dst -> + Reset dst -> Signal src Bool -> Signal dst Bool withLock = withLockN (SNat @4) - -- | Worker function for 'cdcLock'. withLockN :: - forall src dst nRegs . + forall src dst nRegs. ( KnownDomain src , KnownDomain dst - , 2 <= nRegs, nRegs <= 10 ) => + , 2 <= nRegs + , nRegs <= 10 + ) => SNat nRegs -> - Clock src -> Signal src Bool -> - Clock dst -> Reset dst -> + Clock src -> + Signal src Bool -> + Clock dst -> + Reset dst -> Signal src Bool -> Signal dst Bool withLockN nRegs@SNat srcClk asyncSrcRst dstClk dstRst s = @@ -45,11 +53,12 @@ withLockN nRegs@SNat srcClk asyncSrcRst dstClk dstRst s = where counter = register dstClk dstRst enableGen 0 (satSucc SatBound <$> counter) - cdcConfig = XpmCdcSingleConfig - { stages = nRegs - , initialValues = True -- default - , registerInput = False - } + cdcConfig = + XpmCdcSingleConfig + { stages = nRegs + , initialValues = True -- default + , registerInput = False + } sGlitchFree = delay srcClk enableGen False s lockSynced = xpmCdcSingleWith cdcConfig srcClk dstClk (asyncSrcRst .&&. sGlitchFree) diff --git a/bittide/src/Bittide/Transceiver/Comma.hs b/bittide/src/Bittide/Transceiver/Comma.hs index 3b7e5a73e..77ff97918 100644 --- a/bittide/src/Bittide/Transceiver/Comma.hs +++ b/bittide/src/Bittide/Transceiver/Comma.hs @@ -6,15 +6,16 @@ module Bittide.Transceiver.Comma where import Clash.Explicit.Prelude import Bittide.Arithmetic.Time (IndexMs) -import Bittide.SharedTypes (Bytes, Byte) -import Clash.Class.Counter (Counter(countSuccOverflow)) +import Bittide.SharedTypes (Byte, Bytes) +import Clash.Class.Counter (Counter (countSuccOverflow)) -- | Generate commas (transceiver alignment symbols) for a number of milliseconds generator :: - forall ms nBytes dom . + forall ms nBytes dom. ( KnownDomain dom , KnownNat nBytes - , 1 <= ms ) => + , 1 <= ms + ) => SNat ms -> Clock dom -> Reset dom -> @@ -22,11 +23,12 @@ generator :: ( Signal dom (Maybe (Bytes nBytes)) , Signal dom (BitVector nBytes) ) -generator _nCycles@SNat clk rst = unbundle $ - mux - (counter .==. pure maxBound) - (pure (Nothing, 0)) - (pure (Just commas, maxBound)) +generator _nCycles@SNat clk rst = + unbundle + $ mux + (counter .==. pure maxBound) + (pure (Nothing, 0)) + (pure (Just commas, maxBound)) where comma :: Byte comma = 0xbc @@ -36,7 +38,9 @@ generator _nCycles@SNat clk rst = unbundle $ counter = register - clk rst enableGen + clk + rst + enableGen (0 :: Index ms, 0 :: IndexMs dom 1) (next <$> counter) diff --git a/bittide/src/Bittide/Transceiver/Prbs.hs b/bittide/src/Bittide/Transceiver/Prbs.hs index 0db6fdc32..f09bbe565 100644 --- a/bittide/src/Bittide/Transceiver/Prbs.hs +++ b/bittide/src/Bittide/Transceiver/Prbs.hs @@ -1,51 +1,51 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE GADTs #-} --- | A pseudo-random bit sequence (PRBS) generator and checker. These functions --- are used to test the signal integrity of transceivers. The generator generates --- a PRBS stream, while the checker checks whether the received stream is the --- same as the generated stream. Note that the checker is "self synchronizing", --- meaning that it will synchronize with the generator after /polyLength/ cycles. +{- | A pseudo-random bit sequence (PRBS) generator and checker. These functions +are used to test the signal integrity of transceivers. The generator generates +a PRBS stream, while the checker checks whether the received stream is the +same as the generated stream. Note that the checker is "self synchronizing", +meaning that it will synchronize with the generator after /polyLength/ cycles. +-} module Bittide.Transceiver.Prbs where import Clash.Explicit.Prelude --- | Configuration for a PRBS generator or checker. Note that this can only --- specify PRBS streams with two taps: the first tap is always the MSB --- (@polyLength@), and the second tap is the @polyTap@-th bit. --- --- See https://en.wikipedia.org/wiki/Pseudorandom_binary_sequence for more information. +{- | Configuration for a PRBS generator or checker. Note that this can only +specify PRBS streams with two taps: the first tap is always the MSB +(@polyLength@), and the second tap is the @polyTap@-th bit. + +See https://en.wikipedia.org/wiki/Pseudorandom_binary_sequence for more information. +-} data Config polyLength polyTap nBits where Config :: ( KnownNat polyLength , KnownNat polyTap , KnownNat nBits - , 1 <= nBits , 1 <= polyTap , (polyTap + 1) <= polyLength - - -- Same constraints, but written differently for type checking purposes: - , (_n0 + 1) ~ nBits + , -- Same constraints, but written differently for type checking purposes: + (_n0 + 1) ~ nBits , (polyTap + _n1) ~ polyLength , polyTap ~ (_n2 + 1) , _n1 ~ (_n3 + 1) ) => Config polyLength polyTap nBits - -- | PRBS31: @x^31 + x^28 + 1@ -conf31 :: forall n . (KnownNat n, 1 <= n) => Config 31 28 n +conf31 :: forall n. (KnownNat n, 1 <= n) => Config 31 28 n conf31 = leToPlus @1 @n Config -- | PRBS generator, see module documentation. generator :: - forall dom polyLength polyTap nBits . - KnownDomain dom => - Clock dom -> Reset dom -> Enable dom -> + forall dom polyLength polyTap nBits. + (KnownDomain dom) => + Clock dom -> + Reset dom -> + Enable dom -> Config polyLength polyTap nBits -> Signal dom (BitVector nBits) generator clk rst ena Config = @@ -57,24 +57,26 @@ generator clk rst ena Config = (BitVector polyLength, BitVector nBits) go (prbsReg, _) _ = ( last prbs - , pack (reverse $ map msb prbs) ) + , pack (reverse $ map msb prbs) + ) where - prbs :: Vec nBits (BitVector polyLength) - prbs = unfoldrI goPrbs prbsReg - - goPrbs :: BitVector polyLength -> (BitVector polyLength, BitVector polyLength) - goPrbs bv = (o,o) - where - o = newBit +>>. bv - tap = SNat @(polyLength - polyTap) - newBit = bitStep bv tap + prbs :: Vec nBits (BitVector polyLength) + prbs = unfoldrI goPrbs prbsReg + goPrbs :: BitVector polyLength -> (BitVector polyLength, BitVector polyLength) + goPrbs bv = (o, o) + where + o = newBit +>>. bv + tap = SNat @(polyLength - polyTap) + newBit = bitStep bv tap -- | PRBS checker, see module documentation. checker :: - forall dom polyLength polyTap nBits . - KnownDomain dom => - Clock dom -> Reset dom -> Enable dom -> + forall dom polyLength polyTap nBits. + (KnownDomain dom) => + Clock dom -> + Reset dom -> + Enable dom -> Config polyLength polyTap nBits -> Signal dom (BitVector nBits) -> Signal dom (BitVector nBits) @@ -89,22 +91,23 @@ checker clk rst ena Config = mealy clk rst ena go (maxBound, maxBound) , prbsOutPrev ) where - prbsOut :: Vec nBits Bit - prbsState :: BitVector polyLength - (prbsState, prbsOut) = mapAccumL goPrbs prbsReg (reverse $ unpack prbsIn) + prbsOut :: Vec nBits Bit + prbsState :: BitVector polyLength + (prbsState, prbsOut) = mapAccumL goPrbs prbsReg (reverse $ unpack prbsIn) - goPrbs :: BitVector polyLength -> Bit -> (BitVector polyLength, Bit) - goPrbs bv newBit = (o, bitErr) - where - o = newBit +>>. bv - tap = SNat @(polyLength - polyTap) - bitErr = xor newBit (bitStep bv tap) + goPrbs :: BitVector polyLength -> Bit -> (BitVector polyLength, Bit) + goPrbs bv newBit = (o, bitErr) + where + o = newBit +>>. bv + tap = SNat @(polyLength - polyTap) + bitErr = xor newBit (bitStep bv tap) bitStep :: ( BitSize a ~ ((1 + n) + i) , BitPack a , KnownNat n - , KnownNat i ) => + , KnownNat i + ) => a -> SNat n -> Bit @@ -113,24 +116,25 @@ bitStep bv tap = xor (lsb bv) (unpack $ slice tap tap bv) data TrackerState - = Down (Index 127) - -- ^ Link is considered down. Needs 127 cycles of \"good\" input to transition - -- to 'Up'. - | Up - -- ^ Link has not seen errors in at least 127 cycles. + = -- | Link is considered down. Needs 127 cycles of \"good\" input to transition + -- to 'Up'. + Down (Index 127) + | -- | Link has not seen errors in at least 127 cycles. + Up deriving (Eq, Show, Generic, NFDataX) --- | Small state machine tracking whether a link is stable. A link is considered --- stable, if no errors were detected for a number of cycles (see "PrbsTrackerState"). --- Whenever a bit error is detected, it immediately deasserts its output. +{- | Small state machine tracking whether a link is stable. A link is considered +stable, if no errors were detected for a number of cycles (see "PrbsTrackerState"). +Whenever a bit error is detected, it immediately deasserts its output. +-} tracker :: - KnownDomain dom => + (KnownDomain dom) => Clock dom -> Reset dom -> + -- | PRBS error detected Signal dom Bool -> - -- ^ PRBS error detected + -- | Link OK Signal dom Bool - -- ^ Link OK tracker clk rst = mealy clk rst enableGen go initSt where @@ -142,4 +146,4 @@ tracker clk rst = case st of Down 0 -> (Up, False) Down n -> (Down (n - 1), False) - Up -> (Up, True) + Up -> (Up, True) diff --git a/bittide/src/Bittide/Transceiver/ResetManager.hs b/bittide/src/Bittide/Transceiver/ResetManager.hs index 7dc8a1a2b..a4eb934ce 100644 --- a/bittide/src/Bittide/Transceiver/ResetManager.hs +++ b/bittide/src/Bittide/Transceiver/ResetManager.hs @@ -3,9 +3,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE OverloadedRecordDot #-} - +{-# LANGUAGE NoFieldSelectors #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- | Functions to reset the transceiver subsystems during bringup @@ -35,7 +34,7 @@ data Statistics = Statistics , rxFullRetries :: Unsigned 32 -- ^ How many times 'rxRetries' overflowed. I.e., how many times 'RxWait' moved -- the state machine back to 'StartTx'. - , failAfterUps :: Unsigned 32 + , failAfterUps :: Unsigned 32 -- ^ How many times the link failed when in the 'Monitor' state - i.e., after -- detecting it fully worked. This usually happens if the other side drops its -- link because it tried resetting its receive side too many times - see @@ -43,12 +42,13 @@ data Statistics = Statistics } deriving (Generic, NFDataX) --- | Configuration for 'resetManager' --- --- Develop notes: the current API is a balance between the tightest possible --- hardware and the most flexible API. We could make the API more flexible by --- exposing 'MaxTxTimeoutMs' and friends as type parameters, but that severely --- impacts verbosity and readability. +{- | Configuration for 'resetManager' + +Develop notes: the current API is a balance between the tightest possible +hardware and the most flexible API. We could make the API more flexible by +exposing 'MaxTxTimeoutMs' and friends as type parameters, but that severely +impacts verbosity and readability. +-} data Config = Config { txTimeoutMs :: MaxTxTimeoutMs -- ^ Number of milliseconds to wait for the transmit side to be ready, before @@ -62,46 +62,50 @@ data Config = Config } deriving (Generic, NFDataX, Show) --- | Default configuration for 'resetManager' --- --- XXX: Current timeout values for 'TxWait' and 'RxWait' are chosen arbitrarily. --- We should investigate what these values should be for quick bring-up. +{- | Default configuration for 'resetManager' + +XXX: Current timeout values for 'TxWait' and 'RxWait' are chosen arbitrarily. + We should investigate what these values should be for quick bring-up. +-} defConfig :: Config -defConfig = Config - { txTimeoutMs = 1 - , rxTimeoutMs = 5 - , rxRetries = 8 - } +defConfig = + Config + { txTimeoutMs = 1 + , rxTimeoutMs = 5 + , rxRetries = 8 + } --- | Bringing up the transceivers is a stochastic process - at least, that is --- what Xilinx reference designs make us believe. We therefore retry a number of --- times if we don't see sensible data coming in. See the individual constructors --- and 'resetManager' for more information. +{- | Bringing up the transceivers is a stochastic process - at least, that is +what Xilinx reference designs make us believe. We therefore retry a number of +times if we don't see sensible data coming in. See the individual constructors +and 'resetManager' for more information. +-} data State dom - = StartTx - -- ^ Reset everything - transmit and receive side - | StartRx - -- ^ Reset just the receive side - | TxWait (MaxTxTimeoutMs, IndexMs dom 1) - -- ^ Wait for the transmit side to report it is done. After /n/ milliseconds - -- (see type) it times out, moving to 'StartTx'. - | RxWait (MaxRxTimeoutMs, IndexMs dom 1) - -- ^ Wait for the receive side to report it is done _and_ that it can predict - -- the data coming from the other side. After /n/ milliseconds (see type) it - -- times out. Depending on the value of 'ResetStat's 'rxRetries' it will - -- either reset both the receive and the transmit side, or just the receive - -- side. If all is well though, move on to 'Monitor'. - | Monitor - -- ^ Wait till the end of the universe, or until a link goes down - whichever - -- comes first. In case of the latter, the state machine moves to 'StartTx'. + = -- | Reset everything - transmit and receive side + StartTx + | -- | Reset just the receive side + StartRx + | -- | Wait for the transmit side to report it is done. After /n/ milliseconds + -- (see type) it times out, moving to 'StartTx'. + TxWait (MaxTxTimeoutMs, IndexMs dom 1) + | -- | Wait for the receive side to report it is done _and_ that it can predict + -- the data coming from the other side. After /n/ milliseconds (see type) it + -- times out. Depending on the value of 'ResetStat's 'rxRetries' it will + -- either reset both the receive and the transmit side, or just the receive + -- side. If all is well though, move on to 'Monitor'. + RxWait (MaxRxTimeoutMs, IndexMs dom 1) + | -- | Wait till the end of the universe, or until a link goes down - whichever + -- comes first. In case of the latter, the state machine moves to 'StartTx'. + Monitor deriving (Generic, NFDataX, Eq) --- | Reset manager for transceivers: see 'State' for more information on --- this state machine. See 'Statistics' for information on what debug values --- are exported. +{- | Reset manager for transceivers: see 'State' for more information on +this state machine. See 'Statistics' for information on what debug values +are exported. +-} resetManager :: - forall dom . - KnownDomain dom => + forall dom. + (KnownDomain dom) => Config -> Clock dom -> Reset dom -> @@ -109,7 +113,7 @@ resetManager :: "rx_init_done" ::: Signal dom Bool -> "rx_data_good" ::: Signal dom Bool -> ( "reset_all_out" ::: Reset dom - , "reset_rx" ::: Reset dom + , "reset_rx" ::: Reset dom , "stats" ::: Signal dom Statistics ) resetManager config clk rst tx_init_done rx_init_done rx_data_good = @@ -120,7 +124,9 @@ resetManager config clk rst tx_init_done rx_init_done rx_data_good = where (reset_all_out_sig, reset_rx_sig, statistics) = mooreB - clk rst enableGen + clk + rst + enableGen update extractOutput (initState, initStats) @@ -130,12 +136,13 @@ resetManager config clk rst tx_init_done rx_init_done rx_data_good = ) initStats :: Statistics - initStats = Statistics - { txRetries=0 - , rxRetries=0 - , rxFullRetries=0 - , failAfterUps=0 - } + initStats = + Statistics + { txRetries = 0 + , rxRetries = 0 + , rxFullRetries = 0 + , failAfterUps = 0 + } initState :: State dom initState = StartTx @@ -145,36 +152,29 @@ resetManager config clk rst tx_init_done rx_init_done rx_data_good = case st of -- Reset everything: (StartTx, stats) -> (TxWait minBound, stats) - -- Wait for transceiver to indicate it is done (TxWait cntr@(ms, _), stats@Statistics{txRetries}) - | tx_done -> (RxWait minBound, stats) - | ms == config.txTimeoutMs -> (StartTx, stats{txRetries=satSucc SatBound txRetries}) - | otherwise -> (TxWait (countSucc cntr), stats) - + | tx_done -> (RxWait minBound, stats) + | ms == config.txTimeoutMs -> (StartTx, stats{txRetries = satSucc SatBound txRetries}) + | otherwise -> (TxWait (countSucc cntr), stats) -- Reset receive side logic (StartRx, stats) -> (RxWait minBound, stats) - -- Wait for a reliable incoming link. This can fail in multiple ways, see -- 'RxWait'. (RxWait cntr@(ms, _), stats@Statistics{rxRetries, rxFullRetries}) | rx_done && rx_good -> - (Monitor, stats) - + (Monitor, stats) | ms == config.rxTimeoutMs && rxRetries >= config.rxRetries -> - (StartTx, stats{rxFullRetries=satSucc SatBound rxFullRetries}) - + (StartTx, stats{rxFullRetries = satSucc SatBound rxFullRetries}) | ms == config.rxTimeoutMs -> - (StartRx, stats{rxRetries=satSucc SatBound rxRetries}) - + (StartRx, stats{rxRetries = satSucc SatBound rxRetries}) | otherwise -> - (RxWait (countSucc cntr), stats) - + (RxWait (countSucc cntr), stats) -- Monitor link. Move all the way back to 'StartTx' if the link goes down -- for some reason. (Monitor, stats@Statistics{failAfterUps}) | rx_done && rx_good -> (Monitor, stats) - | otherwise -> (StartTx, stats{failAfterUps=satSucc SatBound failAfterUps}) + | otherwise -> (StartTx, stats{failAfterUps = satSucc SatBound failAfterUps}) extractOutput (st, stats) = ( st == StartTx diff --git a/bittide/src/Bittide/Transceiver/WordAlign.hs b/bittide/src/Bittide/Transceiver/WordAlign.hs index f793ece6c..0fb8c9a75 100644 --- a/bittide/src/Bittide/Transceiver/WordAlign.hs +++ b/bittide/src/Bittide/Transceiver/WordAlign.hs @@ -1,24 +1,8 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE NamedFieldPuns #-} --- | Fundamentally, our transceivers are sending over single bits. Through transceiver --- IP we can send words (e.g., 32 bits) on one end and receive words on the other --- end. The IP makes sure that any received are byte aligned. That means that a --- stream: --- --- > --------------------------------------------------- --- > ... | A3 A2 A1 A0 | B3 B2 B1 B0 | C3 C2 C1 C0 | ... --- > --------------------------------------------------- --- --- ..might be, assuming LSB first transmission, received on the other end as: --- --- > ----------------------------------------------------------------- --- > ... | A1 A0 .. .. | A3 A2 B1 B0 | C1 C0 B3 B2 | .. .. C3 C2 | ... --- > ----------------------------------------------------------------- - -- or by any other shift (or none at all!). This module provides utilities to end -- up with a word aligned stream. The basic idea is that, while \"booting\" the -- connection the MSB of each byte is reserved, where an asserted MSB indicates @@ -28,24 +12,40 @@ -- TODO: Remove this module in favor of retry logic. That is, we can keep -- resetting the transceivers until they're aligned. Its unclear how exactly -- this should work though. -module Bittide.Transceiver.WordAlign - ( alignBytesFromMsbs + +{- | Fundamentally, our transceivers are sending over single bits. Through transceiver +IP we can send words (e.g., 32 bits) on one end and receive words on the other +end. The IP makes sure that any received are byte aligned. That means that a +stream: + +> --------------------------------------------------- +> ... | A3 A2 A1 A0 | B3 B2 B1 B0 | C3 C2 C1 C0 | ... +> --------------------------------------------------- + +..might be, assuming LSB first transmission, received on the other end as: + +> ----------------------------------------------------------------- +> ... | A1 A0 .. .. | A3 A2 B1 B0 | C1 C0 B3 B2 | .. .. C3 C2 | ... +> ----------------------------------------------------------------- +-} +module Bittide.Transceiver.WordAlign ( + alignBytesFromMsbs, -- * Convenience functions - , alignSymbol - , splitMsbs - , joinMsbs + alignSymbol, + splitMsbs, + joinMsbs, -- * Core functions and utilities - , AlignmentFn - , aligner - , alignLsbFirst - , alignMsbFirst + AlignmentFn, + aligner, + alignLsbFirst, + alignMsbFirst, -- * Dealigning (for testing purposes) - , dealignLsbFirst - , dealignMsbFirst - ) where + dealignLsbFirst, + dealignMsbFirst, +) where import Clash.Prelude @@ -55,10 +55,11 @@ import Data.Bifunctor (Bifunctor (bimap)) import Data.Maybe (fromMaybe) import Data.Tuple.Extra (curry3) --- | Split the MSBs of a 'BitVector's \"bytes\" into a 'BitVector' of MSBs and a --- 'BitVector' of the remaining bits. +{- | Split the MSBs of a 'BitVector's \"bytes\" into a 'BitVector' of MSBs and a +'BitVector' of the remaining bits. +-} splitMsbs :: - forall nBytes byteWidth . + forall nBytes byteWidth. ( KnownNat nBytes , KnownNat byteWidth , 1 <= byteWidth @@ -68,13 +69,13 @@ splitMsbs :: , BitVector (nBytes * (byteWidth - 1)) ) splitMsbs = - bimap pack pack - . unzip - . unpack @(Vec nBytes (Bit, BitVector (byteWidth - 1))) + bimap pack pack + . unzip + . unpack @(Vec nBytes (Bit, BitVector (byteWidth - 1))) -- | Opposite of 'splitMsbs'. joinMsbs :: - forall nBytes byteWidth . + forall nBytes byteWidth. ( KnownNat nBytes , KnownNat byteWidth , 1 <= byteWidth @@ -82,18 +83,20 @@ joinMsbs :: BitVector nBytes -> BitVector (nBytes * (byteWidth - 1)) -> BitVector (nBytes * byteWidth) -joinMsbs msbs bvs = pack $ - zip - (unpack @(Vec nBytes Bool) msbs) - (unpack @(Vec nBytes (BitVector(byteWidth - 1))) bvs) +joinMsbs msbs bvs = + pack + $ zip + (unpack @(Vec nBytes Bool) msbs) + (unpack @(Vec nBytes (BitVector (byteWidth - 1))) bvs) -alignSymbol :: forall n . (KnownNat n, 1 <= n) => BitVector n +alignSymbol :: forall n. (KnownNat n, 1 <= n) => BitVector n alignSymbol = 1 +>>. 0 --- | Specialized version of 'aligner' that assumes an 'alignSymbol' is stored in --- the MSB of each byte. +{- | Specialized version of 'aligner' that assumes an 'alignSymbol' is stored in +the MSB of each byte. +-} alignBytesFromMsbs :: - forall n dom . + forall n dom. ( HiddenClock dom , KnownNat n , 1 <= n @@ -112,12 +115,12 @@ alignBytesFromMsbs alignFn freeze dat = msbs = unpack . fst . splitMsbs @n <$> dat oneHotDecoder = fromMaybe 0 . elemIndex True -data State n = State { prev :: Bytes n, offset :: Index n } +data State n = State {prev :: Bytes n, offset :: Index n} deriving (Show, Generic, ShowX, NFDataX) -- | Alignment circuit that is generic in its alignment function aligner :: - forall n dom . + forall n dom. ( HiddenClock dom , KnownNat n , 1 <= n @@ -136,20 +139,21 @@ aligner :: -- | Aligned data, according to alignment data saved in the last cycle Signal dom (Bytes n) aligner alignFn = - withEnable enableGen $ - withReset noReset $ - curry3 (mealy go State{prev=0, offset=0} . bundle) + withEnable enableGen + $ withReset noReset + $ curry3 (mealy go State{prev = 0, offset = 0} . bundle) where go :: State n -> (Bool, Index n, Bytes n) -> (State n, Bytes n) go (State{prev, offset}) (freeze, suggestedOffset, current) = - ( State{prev=current, offset=newOffset} - , alignFn offset prev current ) + ( State{prev = current, offset = newOffset} + , alignFn offset prev current + ) where newOffset = if freeze then offset else suggestedOffset -- | (De-)alignment function that can be used in 'aligner' type AlignmentFn n = - KnownNat n => + (KnownNat n) => -- | Offset Index n -> -- | \"Old\" data @@ -176,17 +180,17 @@ alignMsbFirst :: AlignmentFn n alignMsbFirst offset old new = takeMsbs $ shiftBytesL (old ++# new) offset -- | Like 'shiftR', but for 'Bytes' -shiftBytesR :: forall n. KnownNat n => Bytes (2 * n) -> Index n -> Bytes (2 * n) +shiftBytesR :: forall n. (KnownNat n) => Bytes (2 * n) -> Index n -> Bytes (2 * n) shiftBytesR bv n = shiftR bv (8 * fromIntegral n) -- | Like 'shiftL', but for 'Bytes' -shiftBytesL :: forall n. KnownNat n => Bytes (2 * n) -> Index n -> Bytes (2 * n) +shiftBytesL :: forall n. (KnownNat n) => Bytes (2 * n) -> Index n -> Bytes (2 * n) shiftBytesL bv n = shiftL bv (8 * fromIntegral n) -- | Take upper bits of given 'BitVector' -takeMsbs :: forall n. KnownNat n => Bytes (2 * n) -> Bytes n +takeMsbs :: forall n. (KnownNat n) => Bytes (2 * n) -> Bytes n takeMsbs = fst . unpack @(Bytes n, Bytes n) -- | Take lower bits of given 'BitVector' -takeLsbs :: forall n. KnownNat n => Bytes (2 * n) -> Bytes n +takeLsbs :: forall n. (KnownNat n) => Bytes (2 * n) -> Bytes n takeLsbs = truncateB diff --git a/bittide/src/Bittide/Wishbone.hs b/bittide/src/Bittide/Wishbone.hs index aa88e7cd9..8db0ab5f8 100644 --- a/bittide/src/Bittide/Wishbone.hs +++ b/bittide/src/Bittide/Wishbone.hs @@ -1,12 +1,13 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 -{-# OPTIONS_GHC -fconstraint-solver-iterations=100 #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=100 #-} {-# OPTIONS_GHC -fplugin Protocols.Plugin #-} + module Bittide.Wishbone where import Clash.Prelude @@ -14,13 +15,13 @@ import Clash.Prelude import Bittide.DoubleBufferedRam import Bittide.SharedTypes -import Clash.Cores.UART (uart, ValidBaud) -import Clash.Cores.Xilinx.Ila (ila, ilaConfig, IlaConfig(..), Depth) +import Clash.Cores.UART (ValidBaud, uart) +import Clash.Cores.Xilinx.Ila (Depth, IlaConfig (..), ila, ilaConfig) import Clash.Cores.Xilinx.Unisim.DnaPortE2 import Clash.Util.Interpolate import Data.Bifunctor -import Data.Bool(bool) +import Data.Bool (bool) import Data.Constraint.Nat.Extra import Data.Maybe @@ -30,7 +31,6 @@ import Protocols.Wishbone import qualified Protocols.Df as Df import qualified Protocols.Wishbone as Wishbone - {- $setup >>> import Clash.Prelude -} @@ -45,20 +45,25 @@ type MemoryMap nSlaves = Vec nSlaves (Unsigned (CLog 2 nSlaves)) type MappedBusAddrWidth addr nSlaves = addr - CLog 2 nSlaves {-# NOINLINE singleMasterInterconnect #-} --- | Component that maps multiple slave devices to a single master device over the wishbone --- bus. It routes the incoming control signals to a slave device based on the 'MemoryMap', --- a vector of base addresses. + +{- | Component that maps multiple slave devices to a single master device over the wishbone +bus. It routes the incoming control signals to a slave device based on the 'MemoryMap', +a vector of base addresses. +-} singleMasterInterconnect :: - forall dom nSlaves addrW a . - ( HiddenClockResetEnable dom - , KnownNat nSlaves, 1 <= nSlaves - , KnownNat addrW, (CLog 2 nSlaves <= addrW) - , BitPack a - , NFDataX a) => - MemoryMap nSlaves -> - Circuit - (Wishbone dom 'Standard addrW a) - (Vec nSlaves (Wishbone dom 'Standard (MappedBusAddrWidth addrW nSlaves) a)) + forall dom nSlaves addrW a. + ( HiddenClockResetEnable dom + , KnownNat nSlaves + , 1 <= nSlaves + , KnownNat addrW + , (CLog 2 nSlaves <= addrW) + , BitPack a + , NFDataX a + ) => + MemoryMap nSlaves -> + Circuit + (Wishbone dom 'Standard addrW a) + (Vec nSlaves (Wishbone dom 'Standard (MappedBusAddrWidth addrW nSlaves) a)) singleMasterInterconnect (fmap pack -> config) = Circuit go where @@ -67,21 +72,21 @@ singleMasterInterconnect (fmap pack -> config) = route master@(WishboneM2S{..}) slaves = (toMaster, toSlaves) where - oneHotOrZeroSelected = fmap (==addrIndex) config + oneHotOrZeroSelected = fmap (== addrIndex) config (addrIndex, newAddr) = split @_ @_ @(MappedBusAddrWidth addrW nSlaves) addr toSlaves = (\newStrobe -> (updateM2SAddr newAddr master){strobe = strobe && newStrobe}) - <$> oneHotOrZeroSelected + <$> oneHotOrZeroSelected toMaster | busCycle && strobe = foldMaybes - emptyWishboneS2M{err=True} -- master tries to access unmapped memory - (maskToMaybes slaves oneHotOrZeroSelected) + emptyWishboneS2M{err = True} -- master tries to access unmapped memory + (maskToMaybes slaves oneHotOrZeroSelected) | otherwise = emptyWishboneS2M dupWb :: - forall dom aw . + forall dom aw. (KnownDomain dom, KnownNat aw) => Circuit (Wishbone dom 'Standard aw (Bytes 4)) @@ -91,18 +96,19 @@ dupWb :: ) ) dupWb = Circuit go - where - go (m2s0, (s2m0, _)) = - (s2m0, (m2s0, (m2s0, s2m0))) - --- | An ILA monitoring all M2S and S2M signals on a Wishbone bus. Installs two --- extra signals 'capture' and 'trigger' that can be used as defaults for triggering --- the ILA and conditional capturing. Trigger will be active for every valid --- transaction, while capture will be active for as long as trigger and a cycle --- after it. + where + go (m2s0, (s2m0, _)) = + (s2m0, (m2s0, (m2s0, s2m0))) + +{- | An ILA monitoring all M2S and S2M signals on a Wishbone bus. Installs two +extra signals 'capture' and 'trigger' that can be used as defaults for triggering +the ILA and conditional capturing. Trigger will be active for every valid +transaction, while capture will be active for as long as trigger and a cycle +after it. +-} ilaWb :: - forall name dom addrW a . - HiddenClock dom => + forall name dom addrW a. + (HiddenClock dom) => -- | Name of the module of the `ila` wrapper. Naming the internal ILA is -- unreliable when more than one ILA is used with the same arguments, but the -- module name can be set reliably. @@ -126,81 +132,94 @@ ilaWb SSymbol stages0 depth0 = Circuit $ \(m2s, s2m) -> capture = trigger .||. dflipflop trigger ilaInst :: Signal dom () - ilaInst = setName @name $ ila - ((ilaConfig $ - "m2s_addr" - :> "m2s_writeData" - :> "m2s_busSelect" - :> "m2s_busCycle" - :> "m2s_strobe" - :> "m2s_writeEnable" - :> "s2m_readData" - :> "s2m_acknowledge" - :> "s2m_err" - :> "s2m_stall" - :> "s2m_retry" - :> "capture" - :> "trigger" - :> Nil) { advancedTriggers = True, stages = stages0, depth = depth0 }) - hasClock - (Wishbone.addr <$> m2s) - (Wishbone.writeData <$> m2s) - (Wishbone.busSelect <$> m2s) - (Wishbone.busCycle <$> m2s) - (Wishbone.strobe <$> m2s) - (Wishbone.writeEnable <$> m2s) - (Wishbone.readData <$> s2m) - (Wishbone.acknowledge <$> s2m) - (Wishbone.err <$> s2m) - (Wishbone.stall <$> s2m) - (Wishbone.retry <$> s2m) - capture - trigger - in + ilaInst = + setName @name + $ ila + ( ( ilaConfig + $ "m2s_addr" + :> "m2s_writeData" + :> "m2s_busSelect" + :> "m2s_busCycle" + :> "m2s_strobe" + :> "m2s_writeEnable" + :> "s2m_readData" + :> "s2m_acknowledge" + :> "s2m_err" + :> "s2m_stall" + :> "s2m_retry" + :> "capture" + :> "trigger" + :> Nil + ) + { advancedTriggers = True + , stages = stages0 + , depth = depth0 + } + ) + hasClock + (Wishbone.addr <$> m2s) + (Wishbone.writeData <$> m2s) + (Wishbone.busSelect <$> m2s) + (Wishbone.busCycle <$> m2s) + (Wishbone.strobe <$> m2s) + (Wishbone.writeEnable <$> m2s) + (Wishbone.readData <$> s2m) + (Wishbone.acknowledge <$> s2m) + (Wishbone.err <$> s2m) + (Wishbone.stall <$> s2m) + (Wishbone.retry <$> s2m) + capture + trigger + in ilaInst `hwSeqX` (s2m, m2s) --- | Given a vector with elements and a mask, promote all values with a corresponding --- 'True' to 'Just', others to 'Nothing'. --- --- Example: --- --- >>> maskToMaybes ('a' :> 'b' :> Nil) (True :> False :> Nil) --- Just 'a' :> Nothing :> Nil --- +{- | Given a vector with elements and a mask, promote all values with a corresponding +'True' to 'Just', others to 'Nothing'. + +Example: + +>>> maskToMaybes ('a' :> 'b' :> Nil) (True :> False :> Nil) +Just 'a' :> Nothing :> Nil +-} maskToMaybes :: Vec n a -> Vec n Bool -> Vec n (Maybe a) maskToMaybes = zipWith (bool Nothing . Just) --- | Fold 'Maybe's to a single value. If the given vector does not contain any 'Just', --- the default value is picked. Prefers the leftmost value when the vector contains --- multiple 'Just's. --- --- Example: --- --- >>> foldMaybes 'a' (Nothing :> Just 'c' :> Nil) --- 'c' --- >>> foldMaybes 'a' (Just 'b' :> Just 'c' :> Nil) --- 'b' --- >>> foldMaybes 'a' (Nothing :> Nothing :> Nil) --- 'a' --- +{- | Fold 'Maybe's to a single value. If the given vector does not contain any 'Just', +the default value is picked. Prefers the leftmost value when the vector contains +multiple 'Just's. + +Example: + +>>> foldMaybes 'a' (Nothing :> Just 'c' :> Nil) +'c' +>>> foldMaybes 'a' (Just 'b' :> Just 'c' :> Nil) +'b' +>>> foldMaybes 'a' (Nothing :> Nothing :> Nil) +'a' +-} foldMaybes :: a -> Vec n (Maybe a) -> a foldMaybes a Nil = a foldMaybes dflt v@(Cons _ _) = fromMaybe dflt $ fold (<|>) v --- | Version of 'singleMasterInterconnect' that does not use the 'Circuit' abstraction --- from @clash-protocols@ but exposes 'Signal's directly. +{- | Version of 'singleMasterInterconnect' that does not use the 'Circuit' abstraction +from @clash-protocols@ but exposes 'Signal's directly. +-} singleMasterInterconnect' :: - forall dom nSlaves addrW a . - ( HiddenClockResetEnable dom - , KnownNat nSlaves, 1 <= nSlaves - , KnownNat addrW, CLog 2 nSlaves <= addrW - , BitPack a - , NFDataX a) => - MemoryMap nSlaves -> - Signal dom (WishboneM2S addrW (Regs a 8) a) -> - Signal dom (Vec nSlaves (WishboneS2M a)) -> - ( Signal dom (WishboneS2M a) - , Signal dom (Vec nSlaves (WishboneM2S (MappedBusAddrWidth addrW nSlaves) (Regs a 8) a))) + forall dom nSlaves addrW a. + ( HiddenClockResetEnable dom + , KnownNat nSlaves + , 1 <= nSlaves + , KnownNat addrW + , CLog 2 nSlaves <= addrW + , BitPack a + , NFDataX a + ) => + MemoryMap nSlaves -> + Signal dom (WishboneM2S addrW (Regs a 8) a) -> + Signal dom (Vec nSlaves (WishboneS2M a)) -> + ( Signal dom (WishboneS2M a) + , Signal dom (Vec nSlaves (WishboneM2S (MappedBusAddrWidth addrW nSlaves) (Regs a 8) a)) + ) singleMasterInterconnect' config master slaves = (toMaster, bundle toSlaves) where Circuit f = singleMasterInterconnect @dom @nSlaves @addrW @a config @@ -209,11 +228,12 @@ singleMasterInterconnect' config master slaves = (toMaster, bundle toSlaves) Dict -> f (master, unbundle slaves) --- | Takes an input that features no back pressure mechanism and turn it into `Df`. --- This function is unsafe because data can be lost when the input is @Just _@ and --- the receiving circuit tries to apply back pressure. +{- | Takes an input that features no back pressure mechanism and turn it into `Df`. +This function is unsafe because data can be lost when the input is @Just _@ and +the receiving circuit tries to apply back pressure. +-} unsafeToDf :: Circuit (CSignal dom (Maybe a)) (Df dom a) -unsafeToDf = Circuit $ \ (cSig, _) -> (pure (), Df.maybeToData <$> cSig) +unsafeToDf = Circuit $ \(cSig, _) -> (pure (), Df.maybeToData <$> cSig) -- | 'Df' version of 'uart'. uartDf :: @@ -230,32 +250,36 @@ uartDf :: ) uartDf baud = Circuit go where - go ((request, rxBit),_) = + go ((request, rxBit), _) = ( (Ack <$> ack, pure ()) - , (received, txBit) ) + , (received, txBit) + ) where (received, txBit, ack) = uart baud rxBit (Df.dataToMaybe <$> request) --- | Wishbone accessible UART interface with configurable FIFO buffers. --- It takes the depths of the transmit and receive buffers and the baud rate as parameters. --- The function returns a 'Circuit' with a 'Wishbone' interface and a 'CSignal' for the UART --- receive bit as inputs, and outputs a 'CSignal' for the UART transmit bit and a 'CSignal' --- tuple indicating the status of the UART. --- --- The register layout is as follows: --- - Address 0 (BitVector 8): UART data register (read/write) --- - Address 4 (BitVector 2): UART status register (read-only) --- Relevant masks: --- - 0b01: Transmit buffer full --- - 0b10: Receive buffer empty +{- | Wishbone accessible UART interface with configurable FIFO buffers. + It takes the depths of the transmit and receive buffers and the baud rate as parameters. + The function returns a 'Circuit' with a 'Wishbone' interface and a 'CSignal' for the UART + receive bit as inputs, and outputs a 'CSignal' for the UART transmit bit and a 'CSignal' + tuple indicating the status of the UART. + + The register layout is as follows: + - Address 0 (BitVector 8): UART data register (read/write) + - Address 4 (BitVector 2): UART status register (read-only) + Relevant masks: + - 0b01: Transmit buffer full + - 0b10: Receive buffer empty +-} uartWb :: - forall dom addrW nBytes baudRate transmitBufferDepth receiveBufferDepth . - ( HiddenClockResetEnable dom, ValidBaud dom baudRate + forall dom addrW nBytes baudRate transmitBufferDepth receiveBufferDepth. + ( HiddenClockResetEnable dom + , ValidBaud dom baudRate , 1 <= transmitBufferDepth , 1 <= receiveBufferDepth , 2 <= addrW , KnownNat addrW - , KnownNat nBytes, 1 <= nBytes + , KnownNat nBytes + , 1 <= nBytes ) => -- | Recommended value: 16. This seems to be a good balance between resource -- usage and usability. @@ -284,51 +308,71 @@ uartWb txDepth@SNat rxDepth@SNat baud = circuit $ \(wb, uartRx) -> do ( Df dom (BitVector 8) , CSignal dom (Bool, Bool) -- (rxEmpty, txFull) ) - wbToDf = Circuit $ - bimap unbundle unbundle . - unbundle . - fmap go . - bundle . - bimap bundle bundle + wbToDf = + Circuit + $ bimap unbundle unbundle + . unbundle + . fmap go + . bundle + . bimap bundle bundle where go ((WishboneM2S{..}, Df.dataToMaybe -> rxData, fifoFull -> txFull), (Ack txAck, _)) -- not in cycle - | not (busCycle && strobe) - = ( ((emptyWishboneS2M @()) { readData = invalidReq }, Ack False, ()) - , (Df.NoData, status) - ) + | not (busCycle && strobe) = + ( ((emptyWishboneS2M @()){readData = invalidReq}, Ack False, ()) + , (Df.NoData, status) + ) -- illegal addr - | not addrLegal - = ( ((emptyWishboneS2M @()) { err = True, readData = invalidReq }, Ack False, ()) - , (Df.NoData, status) - ) + | not addrLegal = + ( ((emptyWishboneS2M @()){err = True, readData = invalidReq}, Ack False, ()) + , (Df.NoData, status) + ) -- read at 0 | not writeEnable && internalAddr == 0 = - ( ( (emptyWishboneS2M @()) - {acknowledge = True, readData = resize $ fromMaybe 0 rxData}, Ack True, ()) + ( + ( (emptyWishboneS2M @()) + { acknowledge = True + , readData = resize $ fromMaybe 0 rxData + } + , Ack True + , () + ) , (Df.NoData, status) - ) + ) -- write at 0 | writeEnable && internalAddr == 0 = - ( ( (emptyWishboneS2M @()) - {acknowledge = txAck , readData = invalidReq}, Ack False, ()) + ( + ( (emptyWishboneS2M @()) + { acknowledge = txAck + , readData = invalidReq + } + , Ack False + , () + ) , (Df.Data $ resize writeData, status) - ) + ) -- read at 1 | not writeEnable && internalAddr == 1 = - ( ( (emptyWishboneS2M @()) - {acknowledge = True, readData = resize $ pack status}, Ack False, ()) + ( + ( (emptyWishboneS2M @()) + { acknowledge = True + , readData = resize $ pack status + } + , Ack False + , () + ) , (Df.NoData, status) - ) - | otherwise = ((emptyWishboneS2M { err = True }, Ack False, ()), (Df.NoData, status)) + ) + | otherwise = ((emptyWishboneS2M{err = True}, Ack False, ()), (Df.NoData, status)) where (alignedAddr, alignment) = split @_ @(addrW - 2) @2 addr internalAddr = bitCoerce $ resize alignedAddr :: Index 2 addrLegal = alignedAddr <= 1 && alignment == 0 rxEmpty = isNothing rxData status = (rxEmpty, txFull) - invalidReq = deepErrorX - [i|uartWb: Invalid request. + invalidReq = + deepErrorX + [i|uartWb: Invalid request. BUS: {busCycle} STR: {strobe} ADDR: {addr} @@ -336,27 +380,29 @@ uartWb txDepth@SNat rxDepth@SNat baud = circuit $ \(wb, uartRx) -> do ACK:{acknowledge} ERR:{err}|] - -- | State record for the FIFO circuit. data FifoState depth = FifoState - { readPointer :: Index depth - , dataCount :: Index (depth + 1) - } deriving (Generic, NFDataX) + { readPointer :: Index depth + , dataCount :: Index (depth + 1) + } + deriving (Generic, NFDataX) -- | Meta information from 'fifoWithMeta'. data FifoMeta depth = FifoMeta - { fifoEmpty :: Bool - , fifoFull :: Bool + { fifoEmpty :: Bool + , fifoFull :: Bool , fifoDataCount :: Index (depth + 1) - } deriving (Generic, NFDataX) + } + deriving (Generic, NFDataX) --- | A generic First-In-First-Out (FIFO) circuit with a specified depth that exposes --- meta information such as in `FifoMeta`. At least one cycle latency. --- When the reset is high or the enable is low, there will be no outgoing transactions and --- incoming transactions are not acknowledged. +{- | A generic First-In-First-Out (FIFO) circuit with a specified depth that exposes +meta information such as in `FifoMeta`. At least one cycle latency. +When the reset is high or the enable is low, there will be no outgoing transactions and +incoming transactions are not acknowledged. +-} fifoWithMeta :: - forall dom a depth . - (HiddenClockResetEnable dom, 1 <= depth, NFDataX a) => + forall dom a depth. + (HiddenClockResetEnable dom, 1 <= depth, NFDataX a) => -- | The depth of the FIFO, should be at least 1. SNat depth -> -- | Consumes @Df dom a@, produces @Df dom a@ along with ready signal and data count. @@ -367,26 +413,30 @@ fifoWithMeta depth@SNat = Circuit circuitFunction where circuitActive = unsafeToActiveLow hasReset .&&. fromEnable hasEnable bramOut = - readNew (blockRamU NoClearOnReset depth (errorX "No reset function")) - readAddr writeOp + readNew + (blockRamU NoClearOnReset depth (errorX "No reset function")) + readAddr + writeOp (readAddr, writeOp, fifoOut, readyOut, fifoMeta) = mealyB go initialState (circuitActive, fifoIn, readyIn, bramOut) -- Initial state of the FIFO - initialState = FifoState - { readPointer = 0 - , dataCount = 0 - } + initialState = + FifoState + { readPointer = 0 + , dataCount = 0 + } go :: FifoState depth -> (Bool, Df.Data a, Ack, a) -> ( FifoState depth - , (Index depth, Maybe (Index depth, a), Df.Data a, Bool, FifoMeta depth)) - go state@FifoState{..} (False, _, _,_) = (state,(readPointer, Nothing, Df.NoData, False, fifoMeta)) + , (Index depth, Maybe (Index depth, a), Df.Data a, Bool, FifoMeta depth) + ) + go state@FifoState{..} (False, _, _, _) = (state, (readPointer, Nothing, Df.NoData, False, fifoMeta)) where fifoEmpty = dataCount == 0 fifoFull = dataCount == maxBound - fifoMeta = FifoMeta {fifoEmpty, fifoFull, fifoDataCount = dataCount} + fifoMeta = FifoMeta{fifoEmpty, fifoFull, fifoDataCount = dataCount} go FifoState{..} (True, Df.dataToMaybe -> fifoIn, Ack readyIn, bramOut) = (nextState, output) where fifoEmpty = dataCount == 0 @@ -404,29 +454,32 @@ fifoWithMeta depth@SNat = Circuit circuitFunction dataCountDx = case (writeSuccess, readSuccess) of (True, False) -> satSucc SatError (False, True) -> satPred SatError - _ -> id + _ -> id - nextState = FifoState - { readPointer = readPointerNext - , dataCount = dataCountNext - } + nextState = + FifoState + { readPointer = readPointerNext + , dataCount = dataCountNext + } - fifoMeta = FifoMeta {fifoEmpty, fifoFull, fifoDataCount = dataCount} + fifoMeta = FifoMeta{fifoEmpty, fifoFull, fifoDataCount = dataCount} output = (readPointerNext, writeOpGo, fifoOutGo, not fifoFull, fifoMeta) --- | Transforms a wishbone interface into a vector based interface. --- Write operations will produce a 'Just (Bytes nBytes)' on the index corresponding --- to the word-aligned Wishbone address. --- Read operations will read from the index corresponding to the world-aligned --- Wishbone address. +{- | Transforms a wishbone interface into a vector based interface. +Write operations will produce a 'Just (Bytes nBytes)' on the index corresponding +to the word-aligned Wishbone address. +Read operations will read from the index corresponding to the world-aligned +Wishbone address. +-} wbToVec :: - forall nBytes addrW nRegisters . + forall nBytes addrW nRegisters. ( KnownNat nBytes , 1 <= nBytes , KnownNat addrW , 2 <= addrW , KnownNat nRegisters - , 1 <= nRegisters) => + , 1 <= nRegisters + ) => -- | Readable data. Vec nRegisters (Bytes nBytes) -> -- | Wishbone bus (master to slave) @@ -435,7 +488,8 @@ wbToVec :: -- 1. Written data -- 2. Outgoing wishbone bus (slave to master) ( Vec nRegisters (Maybe (Bytes nBytes)) - , WishboneS2M (Bytes nBytes)) + , WishboneS2M (Bytes nBytes) + ) wbToVec readableData WishboneM2S{..} = (writtenData, wbS2M) where (alignedAddress, alignment) = split @_ @(addrW - 2) @2 addr @@ -452,32 +506,37 @@ wbToVec readableData WishboneM2S{..} = (writtenData, wbS2M) | otherwise = repeat Nothing wbS2M = (emptyWishboneS2M @(Bytes 4)){acknowledge, readData, err} --- | Wishbone accessible circuit that contains a free running 64 bit counter. We can --- observe this counter to get a sense of time, overflows should be accounted for by --- the master. +{- | Wishbone accessible circuit that contains a free running 64 bit counter. We can +observe this counter to get a sense of time, overflows should be accounted for by +the master. +-} timeWb :: - forall dom addrW . + forall dom addrW. ( HiddenClockResetEnable dom , KnownNat addrW , 2 <= addrW - , 1 <= DomainPeriod dom) => + , 1 <= DomainPeriod dom + ) => Circuit (Wishbone dom 'Standard addrW (Bytes 4)) () -timeWb = Circuit $ \(wbM2S, _) -> (mealy goMealy (0,0) wbM2S, ()) +timeWb = Circuit $ \(wbM2S, _) -> (mealy goMealy (0, 0) wbM2S, ()) where goMealy (frozen, count :: Unsigned 64) wbM2S = ((nextFrozen, succ count), wbS2M) - where + where freq = natToNum @(DomainToHz dom) :: Unsigned 64 nextFrozen = if isJust (head writes) then count else frozen RegisterBank (splitAtI -> (frozenMsbs, frozenLsbs)) = getRegsBe @8 frozen RegisterBank (splitAtI -> (freqMsbs, freqLsbs)) = getRegsBe @8 freq - (writes, wbS2M) = wbToVec - (0 :> fmap pack (frozenLsbs :> frozenMsbs :> freqLsbs :> freqMsbs :> Nil)) wbM2S - --- | Wishbone wrapper for DnaPortE2, adds extra register with wishbone interface --- to access the DNA device identifier. The DNA device identifier is a 96-bit --- value, stored in big-endian format. + (writes, wbS2M) = + wbToVec + (0 :> fmap pack (frozenLsbs :> frozenMsbs :> freqLsbs :> freqMsbs :> Nil)) + wbM2S + +{- | Wishbone wrapper for DnaPortE2, adds extra register with wishbone interface +to access the DNA device identifier. The DNA device identifier is a 96-bit +value, stored in big-endian format. +-} readDnaPortE2Wb :: - forall dom addrW nBytes . + forall dom addrW nBytes. ( HiddenClockResetEnable dom , KnownNat addrW , 2 <= addrW @@ -493,8 +552,11 @@ readDnaPortE2Wb simDna = circuit $ \wb -> do idC -< () where maybeDna = readDnaPortE2 hasClock hasReset hasEnable simDna - regRst = unsafeFromActiveHigh $ register True - $ fmap isNothing maybeDna .||. unsafeToActiveHigh hasReset + regRst = + unsafeFromActiveHigh + $ register True + $ fmap isNothing maybeDna + .||. unsafeToActiveHigh hasReset reg = withReset regRst $ registerWbC @dom @_ @nBytes @addrW WishbonePriority 0 - dnaCircuit :: Circuit () (Df dom (BitVector 96)) + dnaCircuit :: Circuit () (Df dom (BitVector 96)) dnaCircuit = Circuit $ const ((), Df.maybeToData <$> maybeDna) diff --git a/bittide/src/Clash/Cores/Extra.hs b/bittide/src/Clash/Cores/Extra.hs index 2e7811c56..ba0eb78ba 100644 --- a/bittide/src/Clash/Cores/Extra.hs +++ b/bittide/src/Clash/Cores/Extra.hs @@ -10,35 +10,35 @@ module Clash.Cores.Extra where import Clash.Annotations.Primitive import Clash.Explicit.Prelude hiding (Fixed, (:<)) -import Clash.Netlist.Types (TemplateFunction(..), BlackBoxContext(..), HWType(..)) +import Clash.Netlist.Types (BlackBoxContext (..), HWType (..), TemplateFunction (..)) import Clash.Netlist.Util (stripVoid) -import Data.Fixed (Fixed(..), E3) -import Data.List.Infinite (Infinite((:<)), (...)) +import Data.Fixed (E3, Fixed (..)) +import Data.List.Infinite (Infinite ((:<)), (...)) import Data.Maybe (fromMaybe) import Data.String.Interpolate (__i) +{- | A typical dual flipflop synchronizer, prepended with a flipflop operating +in the source domain. The two flipflops operating in the target domain are +packed tightly together using Vivado's ASYNC_REG synthesis attribute. For more +information see: --- | A typical dual flipflop synchronizer, prepended with a flipflop operating --- in the source domain. The two flipflops operating in the target domain are --- packed tightly together using Vivado's ASYNC_REG synthesis attribute. For more --- information see: --- --- https://docs.xilinx.com/r/en-US/ug901-vivado-synthesis/ASYNC_REG --- --- HDL generation also generates an @.sdc@ file for Vivado with the correct --- timing constraints for the synchronizer. The HDL contains unique register --- names so the SDC can match on just these registers. --- --- __N.B.__: You cannot synchronize words by combining multiple instantiations --- of 'safeDffSynchronizer'. If you want to do this, look into --- 'dcFifo'. --- + https://docs.xilinx.com/r/en-US/ug901-vivado-synthesis/ASYNC_REG + +HDL generation also generates an @.sdc@ file for Vivado with the correct +timing constraints for the synchronizer. The HDL contains unique register +names so the SDC can match on just these registers. + +__N.B.__: You cannot synchronize words by combining multiple instantiations + of 'safeDffSynchronizer'. If you want to do this, look into + 'dcFifo'. +-} safeDffSynchronizer :: forall dom1 dom2 a. ( KnownDomain dom1 , KnownDomain dom2 , NFDataX a - , BitSize a ~ 1 ) => + , BitSize a ~ 1 + ) => Clock dom1 -> Clock dom2 -> a -> @@ -47,14 +47,16 @@ safeDffSynchronizer :: safeDffSynchronizer clk1 clk2 initVal i = snd $ safeDffSynchronizer0 clk1 clk2 initVal i --- | Like 'safeDffSynchronizer', but the source register is provided on the --- output for further use in the source domain +{- | Like 'safeDffSynchronizer', but the source register is provided on the +output for further use in the source domain +-} safeDffSynchronizer0 :: forall dom1 dom2 a. ( KnownDomain dom1 , KnownDomain dom2 , NFDataX a - , BitSize a ~ 1 ) => + , BitSize a ~ 1 + ) => Clock dom1 -> Clock dom2 -> a -> @@ -62,36 +64,40 @@ safeDffSynchronizer0 :: (Signal dom1 a, Signal dom2 a) safeDffSynchronizer0 clk1 clk2 initVal i = (sOut, dOut) where - dOut = flipflop clk2 - . flipflop clk2 - $ unsafeSynchronizer clk1 clk2 sOut + dOut = + flipflop clk2 + . flipflop clk2 + $ unsafeSynchronizer clk1 clk2 sOut sOut = flipflop clk1 i - flipflop :: KnownDomain dom => Clock dom -> Signal dom a -> Signal dom a + flipflop :: (KnownDomain dom) => Clock dom -> Signal dom a -> Signal dom a flipflop clk = delay clk enableGen initVal {-# OPAQUE safeDffSynchronizer0 #-} {-# ANN safeDffSynchronizer0 hasBlackBox #-} -{-# ANN safeDffSynchronizer0 ( - let - ( dom1 - :< dom2 - :< _nfdatax - :< _bitsize - :< clock1 - :< clock2 - :< initVal - :< inp - :< _ - ) = ((0::Int)...) - - ( regA - :< regB - :< regC - :< _ - ) = ((0::Int)...) - funcName = 'safeDffSynchronizer0 - tfName = 'safeDffSynchronizerTF - in - InlineYamlPrimitive [Verilog, SystemVerilog] [__i| +{-# ANN + safeDffSynchronizer0 + ( let + ( dom1 + :< dom2 + :< _nfdatax + :< _bitsize + :< clock1 + :< clock2 + :< initVal + :< inp + :< _ + ) = ((0 :: Int) ...) + + ( regA + :< regB + :< regC + :< _ + ) = ((0 :: Int) ...) + funcName = 'safeDffSynchronizer0 + tfName = 'safeDffSynchronizerTF + in + InlineYamlPrimitive + [Verilog, SystemVerilog] + [__i| BlackBox: kind: Declaration name: #{funcName} @@ -116,30 +122,35 @@ safeDffSynchronizer0 clk1 clk2 initVal i = (sOut, dOut) name: dff_sync format: Haskell templateFunction: #{tfName} -|]) #-} -{-# ANN safeDffSynchronizer0 ( - let - ( dom1 - :< dom2 - :< _nfdatax - :< _bitsize - :< clock1 - :< clock2 - :< initVal - :< inp - :< _ - ) = ((0::Int)...) - - ( regA - :< regB - :< regC - :< block - :< _ - ) = ((0::Int)...) - funcName = 'safeDffSynchronizer0 - tfName = 'safeDffSynchronizerTF - in - InlineYamlPrimitive [VHDL] [__i| +|] + ) + #-} +{-# ANN + safeDffSynchronizer0 + ( let + ( dom1 + :< dom2 + :< _nfdatax + :< _bitsize + :< clock1 + :< clock2 + :< initVal + :< inp + :< _ + ) = ((0 :: Int) ...) + + ( regA + :< regB + :< regC + :< block + :< _ + ) = ((0 :: Int) ...) + funcName = 'safeDffSynchronizer0 + tfName = 'safeDffSynchronizerTF + in + InlineYamlPrimitive + [VHDL] + [__i| BlackBox: kind: Declaration name: #{funcName} @@ -180,32 +191,37 @@ safeDffSynchronizer0 clk1 clk2 initVal i = (sOut, dOut) name: dff_sync format: Haskell templateFunction: #{tfName} -|]) #-} +|] + ) + #-} safeDffSynchronizerTF :: TemplateFunction safeDffSynchronizerTF = let - ( dom1Used - :< dom2Used - :< _nfdatax - :< _bitsize - :< _clock1 - :< _clock2 - :< _initVal - :< _inp - :< _ - ) = ((0::Int)...) - in TemplateFunction [dom1Used, dom2Used] (const True) $ \bbCtx -> - pure . fromMaybe (error "Pattern match failure") $ do + ( dom1Used + :< dom2Used + :< _nfdatax + :< _bitsize + :< _clock1 + :< _clock2 + :< _initVal + :< _inp + :< _ + ) = ((0 :: Int) ...) + in + TemplateFunction [dom1Used, dom2Used] (const True) $ \bbCtx -> + pure . fromMaybe (error "Pattern match failure") $ do [compName] <- pure (bbQsysIncName bbCtx) [ (_, stripVoid -> dom1, _) - , (_, stripVoid -> dom2, _) - , _nfdatax - , _bitsize - , _clock1 - , _clock2 - , _initVal - , _inp ] <- pure (bbInputs bbCtx) + , (_, stripVoid -> dom2, _) + , _nfdatax + , _bitsize + , _clock1 + , _clock2 + , _initVal + , _inp + ] <- + pure (bbInputs bbCtx) KnownDomain _ dom1Period _ _ _ _ <- pure dom1 KnownDomain _ dom2Period _ _ _ _ <- pure dom2 let minPeriodNs = MkFixed $ min dom1Period dom2Period :: Fixed E3 diff --git a/bittide/src/Clash/Cores/UART/Extra.hs b/bittide/src/Clash/Cores/UART/Extra.hs index 8c891b1d8..25367c09b 100644 --- a/bittide/src/Clash/Cores/UART/Extra.hs +++ b/bittide/src/Clash/Cores/UART/Extra.hs @@ -1,14 +1,14 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fplugin Protocols.Plugin #-} -module Clash.Cores.UART.Extra - ( module Clash.Cores.UART.Extra - , System.IO.stdin - , System.IO.stdout - ) where + +module Clash.Cores.UART.Extra ( + module Clash.Cores.UART.Extra, + System.IO.stdin, + System.IO.stdout, +) where import Clash.Prelude @@ -17,7 +17,7 @@ import Data.Char import Data.Maybe import GHC.IO import Protocols -import Protocols.Df hiding (catMaybes, sample, pure) +import Protocols.Df hiding (catMaybes, pure, sample) import System.IO import Bittide.Wishbone @@ -27,11 +27,12 @@ import qualified Protocols.Df as Df -- | The maximum baud rate for a given domain, useful for simulation purposes type MaxBaudRate dom = Div (DomainToHz dom) 16 --- | A simulation function for circuits that expose a UART connection. --- This function reads from the provided input handle and feeds that to the UART circuit. --- Incoming uart data is written the the output handle. +{- | A simulation function for circuits that expose a UART connection. +This function reads from the provided input handle and feeds that to the UART circuit. +Incoming uart data is written the the output handle. +-} uartIO :: - forall dom baud . + forall dom baud. (KnownDomain dom, ValidBaud dom baud) => -- | A handle for the input data stream, use `stdin` for terminal input. Handle -> @@ -48,7 +49,7 @@ uartIO inputHandle outputHandle baud uartCircuit = do where printList :: [(BitVector 8)] -> IO () printList [] = pure () - printList (x:xs) = do + printList (x : xs) = do hPutChar outputHandle . chr $ fromIntegral x hFlush outputHandle printList xs @@ -61,16 +62,17 @@ uartIO inputHandle outputHandle baud uartCircuit = do else pure Nothing input = fmap (fmap (fromIntegral . ord) . unsafePerformIO) $ ioList inputHandle - ioCircuit = circuit $ \ _n -> do + ioCircuit = circuit $ \_n -> do (receivedByte, txBit) <- uartWithLists baud input -< rxBit rxBit <- uartCircuit -< txBit unsafeToDf -< receivedByte --- | A simulation function for circuits that expose a UART connection. --- This function transforms a list into its respective uart driver, it also returns --- a `CSignal` containing the `BitVector 8`s that are received on the incoming uart signal. +{- | A simulation function for circuits that expose a UART connection. +This function transforms a list into its respective uart driver, it also returns +a `CSignal` containing the `BitVector 8`s that are received on the incoming uart signal. +-} uartWithLists :: - forall dom baud . + forall dom baud. (KnownDomain dom, ValidBaud dom baud) => -- | The baud rate for the UART communication. SNat baud -> @@ -78,8 +80,8 @@ uartWithLists :: [Maybe (BitVector 8)] -> -- | The circuit to be simulated. Circuit (CSignal dom Bit) (CSignal dom (Maybe (BitVector 8)), CSignal dom Bit) -uartWithLists baud input = +uartWithLists baud input = withClock clockGen $ withReset resetGen $ circuit $ \txBit -> do - dfIn <- drive def{resetCycles = 1} input - (receivedByte, rxBit) <- exposeEnable uartDf enableGen baud -< (dfIn, txBit) - idC -< (receivedByte, rxBit) + dfIn <- drive def{resetCycles = 1} input + (receivedByte, rxBit) <- exposeEnable uartDf enableGen baud -< (dfIn, txBit) + idC -< (receivedByte, rxBit) diff --git a/bittide/src/Clash/Cores/Xilinx/Extra.hs b/bittide/src/Clash/Cores/Xilinx/Extra.hs index 357ad1bde..e3a7bd18e 100644 --- a/bittide/src/Clash/Cores/Xilinx/Extra.hs +++ b/bittide/src/Clash/Cores/Xilinx/Extra.hs @@ -5,14 +5,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Clash.Cores.Xilinx.Extra - ( ibufds - , readDnaPortE2I - , module GTH +module Clash.Cores.Xilinx.Extra ( + ibufds, + readDnaPortE2I, + module GTH, -- * Internal - , ibufdsTF - ) where + ibufdsTF, +) where import Clash.Prelude @@ -34,62 +34,66 @@ import qualified Prelude as P -- | Like 'dnaPortE2', but with a hidden clock, reset, and enable readDnaPortE2I :: - HiddenClockResetEnable dom => + (HiddenClockResetEnable dom) => -- | DNA value to use in simulation BitVector 96 -> -- | Extracted DNA value from FPGA. Will take ~100 cycles to become available. Signal dom (Maybe (BitVector 96)) readDnaPortE2I = hideClockResetEnable readDnaPortE2 --- | A differential input buffer. For more information see: --- --- https://docs.xilinx.com/r/en-US/ug974-vivado-ultrascale-libraries/IBUFDS --- -ibufds :: (KnownDomain dom) => DiffClock dom -> Clock dom +{- | A differential input buffer. For more information see: + + https://docs.xilinx.com/r/en-US/ug974-vivado-ultrascale-libraries/IBUFDS +-} +ibufds :: (KnownDomain dom) => DiffClock dom -> Clock dom ibufds !_ = clockGen {-# ANN ibufds hasBlackBox #-} {-# OPAQUE ibufds #-} -{-# ANN ibufds (InlineYamlPrimitive [minBound..] [__i| +{-# ANN + ibufds + ( InlineYamlPrimitive + [minBound ..] + [__i| BlackBox: name: Clash.Cores.Xilinx.Extra.ibufds kind: Declaration format: Haskell templateFunction: Clash.Cores.Xilinx.Extra.ibufdsTF - |]) #-} + |] + ) + #-} --- | Template function for 'ibufds'. --- --- TODO: Upstream to @clash-cores@ +{- | Template function for 'ibufds'. + +TODO: Upstream to @clash-cores@ +-} ibufdsTF :: TemplateFunction ibufdsTF = TemplateFunction used valid go where used = [0, 1] valid = const True - go :: Backend s => BlackBoxContext -> State s Doc + go :: (Backend s) => BlackBoxContext -> State s Doc go bbCtx - | [ _knownDomain, clk] <- P.map fst (DSL.tInputs bbCtx) + | [_knownDomain, clk] <- P.map fst (DSL.tInputs bbCtx) , DataCon (Product "Clash.Signal.Internal.DiffClock" _ clkTys) _ clkEs <- DSL.eex clk , [clkP@(Identifier _ Nothing), clkN@(Identifier _ Nothing)] <- clkEs - , [clkPTy, clkNTy] <- clkTys - = do - instLabel <- Id.makeBasic "ibufds_inst" - - DSL.declarationReturn bbCtx "ibufds_block" $ do - ibufdsOut <- DSL.declare "ibufds_out" Bit - - let - compName = "IBUFDS" - compInps = [("I", Bit), ("IB", Bit)] - compOuts = [("O", Bit)] - inps = [("I", DSL.TExpr clkPTy clkP), ("IB", DSL.TExpr clkNTy clkN)] - outs = [("O", ibufdsOut)] - + , [clkPTy, clkNTy] <- clkTys = + do + instLabel <- Id.makeBasic "ibufds_inst" - DSL.compInBlock compName compInps compOuts - DSL.instDecl Empty (Id.unsafeMake compName) instLabel [] inps outs + DSL.declarationReturn bbCtx "ibufds_block" $ do + ibufdsOut <- DSL.declare "ibufds_out" Bit - pure [ibufdsOut] + let + compName = "IBUFDS" + compInps = [("I", Bit), ("IB", Bit)] + compOuts = [("O", Bit)] + inps = [("I", DSL.TExpr clkPTy clkP), ("IB", DSL.TExpr clkNTy clkN)] + outs = [("O", ibufdsOut)] + DSL.compInBlock compName compInps compOuts + DSL.instDecl Empty (Id.unsafeMake compName) instLabel [] inps outs + pure [ibufdsOut] go bbCtx = error ("ibufdsTemplate:\n\n" <> ppShow bbCtx) diff --git a/bittide/src/Clash/Cores/Xilinx/GTH.hs b/bittide/src/Clash/Cores/Xilinx/GTH.hs index 8397a31a8..ba7ca1c66 100644 --- a/bittide/src/Clash/Cores/Xilinx/GTH.hs +++ b/bittide/src/Clash/Cores/Xilinx/GTH.hs @@ -3,4 +3,5 @@ -- SPDX-License-Identifier: Apache-2.0 module Clash.Cores.Xilinx.GTH (module X) where + import Clash.Cores.Xilinx.GTH.Internal as X diff --git a/bittide/src/Clash/Cores/Xilinx/GTH/BlackBoxes.hs b/bittide/src/Clash/Cores/Xilinx/GTH/BlackBoxes.hs index c54c46f47..23cea2c4c 100644 --- a/bittide/src/Clash/Cores/Xilinx/GTH/BlackBoxes.hs +++ b/bittide/src/Clash/Cores/Xilinx/GTH/BlackBoxes.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -21,24 +20,33 @@ import Clash.Netlist.BlackBox.Types (BlackBoxFunction, emptyBlackBoxMeta) import Clash.Netlist.BlackBox.Util (exprToString) import Clash.Netlist.Types -import Clash.Cores.Xilinx.Internal - (defIpConfig, IpConfig(properties), property, renderTcl, TclPurpose(..), BraceTcl(..)) +import Clash.Cores.Xilinx.Internal ( + BraceTcl (..), + IpConfig (properties), + TclPurpose (..), + defIpConfig, + property, + renderTcl, + ) -import qualified Clash.Primitives.DSL as DSL +import qualified Clash.Netlist.BlackBox.Types as N import qualified Clash.Netlist.Id as Id import qualified Clash.Netlist.Types as N -import qualified Clash.Netlist.BlackBox.Types as N +import qualified Clash.Primitives.DSL as DSL -gthCoreBBF :: HasCallStack => BlackBoxFunction +gthCoreBBF :: (HasCallStack) => BlackBoxFunction gthCoreBBF _isD _primName _args _resTys = pure $ Right (bbMeta, bb) where - bbMeta = emptyBlackBoxMeta - { N.bbKind = N.TDecl - , N.bbIncludes = - [ ( ("gth", "clash.tcl") - , BBFunction (show 'gthCoreTclTF) 0 gthCoreTclTF) - ] - } + bbMeta = + emptyBlackBoxMeta + { N.bbKind = N.TDecl + , N.bbIncludes = + [ + ( ("gth", "clash.tcl") + , BBFunction (show 'gthCoreTclTF) 0 gthCoreTclTF + ) + ] + } bb :: BlackBox bb = BBFunction (show 'gthCoreTF) 0 gthCoreTF @@ -50,248 +58,222 @@ nNameArgs :: Int nNameArgs = 2 -- | Instantiate IP generated with 'gthCoreTclTF' -gthCoreTF :: HasCallStack => TemplateFunction +gthCoreTF :: (HasCallStack) => TemplateFunction gthCoreTF = TemplateFunction - [0..10] + [0 .. 10] (const True) gthCoreBBTF gthCoreBBTF :: - Backend s => + (Backend s) => BlackBoxContext -> State s Doc gthCoreBBTF bbCtx - | args@[ - _gthrxn_in -- " ::: Signal rxS (BitVector ChansUsed) - , _gthrxp_in -- " ::: Signal rxS (BitVector ChansUsed) - , gtwiz_reset_clk_freerun_in -- " ::: Clock freerun - , _gtwiz_reset_all_in -- " ::: Reset freerun - , _gtwiz_reset_rx_datapath_in -- " ::: Reset freerun - , _gtwiz_userdata_tx_in -- " ::: Signal txUser2 (BitVector (ChansUsed*TX_DATA_WIDTH)) - , _txctrl2_in -- " ::: Signal txUser2 (BitVector (ChansUsed*TX_DATA_WIDTH/8)) - , _gtrefclk0_in -- " ::: Clock refclk0 - ] <- drop (nConstraints + nNameArgs) $ map fst (DSL.tInputs bbCtx) + | args@[ _gthrxn_in -- " ::: Signal rxS (BitVector ChansUsed) + , _gthrxp_in -- " ::: Signal rxS (BitVector ChansUsed) + , gtwiz_reset_clk_freerun_in -- " ::: Clock freerun + , _gtwiz_reset_all_in -- " ::: Reset freerun + , _gtwiz_reset_rx_datapath_in -- " ::: Reset freerun + , _gtwiz_userdata_tx_in -- " ::: Signal txUser2 (BitVector (ChansUsed*TX_DATA_WIDTH)) + , _txctrl2_in -- " ::: Signal txUser2 (BitVector (ChansUsed*TX_DATA_WIDTH/8)) + , _gtrefclk0_in -- " ::: Clock refclk0 + ] <- + drop (nConstraints + nNameArgs) $ map fst (DSL.tInputs bbCtx) , [tResult] <- map DSL.ety (DSL.tResults bbCtx) - , [gthCoreName] <- N.bbQsysIncName bbCtx - = do - - gthCoreInstName <- Id.makeBasic "gthcore_inst" - - let - chansUsed = 1 - tX_DATA_WIDTH = 64 - rX_DATA_WIDTH = tX_DATA_WIDTH - compInps = - [ - ("gthrxn_in", N.BitVector chansUsed) - , ("gthrxp_in", N.BitVector chansUsed) - , ("gtwiz_reset_clk_freerun_in", N.Clock "freerun" ) - , ("gtwiz_reset_all_in", N.Reset "freerun" ) - - , ("gtwiz_reset_rx_datapath_in", N.Reset "freerun" ) - , ("gtwiz_userdata_tx_in", N.BitVector (chansUsed*tX_DATA_WIDTH)) - , ("txctrl2_in", N.BitVector (chansUsed*(tX_DATA_WIDTH `div` 8))) - - -- , ("gtrefclk00_in", N.Clock "refclk00" ) - , ("gtrefclk0_in", N.Clock "refclk0" ) - ] <> map (fmap DSL.ety) otherInps - - otherInps = - [ ("drpclk_in", gtwiz_reset_clk_freerun_in) - - , ("txctrl0_in", DSL.bvLit 16 0) - , ("txctrl1_in", DSL.bvLit 16 0) - - , ("gtwiz_reset_tx_pll_and_datapath_in", DSL.bvLit 1 0) - , ("gtwiz_reset_tx_datapath_in", DSL.bvLit 1 0) - , ("gtwiz_reset_rx_pll_and_datapath_in", DSL.bvLit 1 0) - - , ("tx8b10ben_in", DSL.bvLit 1 1) - , ("rx8b10ben_in", DSL.bvLit 1 1) - - , ("gtwiz_userclk_tx_reset_in", DSL.bvLit 1 0) - , ("gtwiz_userclk_rx_reset_in", DSL.bvLit 1 0) - - , ("rxcommadeten_in", DSL.bvLit 1 1) - , ("rxmcommaalignen_in", DSL.bvLit 1 1) - , ("rxpcommaalignen_in", DSL.bvLit 1 1) - ] - compOuts = - [ - ("gthtxn_out", N.BitVector chansUsed) - , ("gthtxp_out", N.BitVector chansUsed) - , ("gtwiz_userclk_tx_usrclk2_out", N.Clock "txUser2") - , ("gtwiz_userclk_rx_usrclk2_out", N.Clock "rxUser2") - , ("gtwiz_userdata_rx_out", N.BitVector (chansUsed*rX_DATA_WIDTH)) - , ("gtwiz_reset_tx_done_out", N.BitVector 1) - , ("gtwiz_reset_rx_done_out", N.BitVector 1) - - , ("gtwiz_userclk_tx_active_out", N.BitVector 1) - - , ("rxctrl0_out", N.BitVector 16) - , ("rxctrl1_out", N.BitVector 16) - , ("rxctrl2_out", N.BitVector 8) - , ("rxctrl3_out", N.BitVector 8) - ] - - DSL.declarationReturn bbCtx "gthCore_inst_block" $ do - - DSL.compInBlock gthCoreName compInps compOuts - - let inps = zip (fst <$> compInps) args <> otherInps - outs <- mapM (uncurry DSL.declare) compOuts - DSL.instDecl - N.Empty - (Id.unsafeMake gthCoreName) - gthCoreInstName - [] - inps - (zip (fst <$> compOuts) outs) - pure [DSL.constructProduct tResult outs] - + , [gthCoreName] <- N.bbQsysIncName bbCtx = + do + gthCoreInstName <- Id.makeBasic "gthcore_inst" + + let + chansUsed = 1 + tX_DATA_WIDTH = 64 + rX_DATA_WIDTH = tX_DATA_WIDTH + compInps = + [ ("gthrxn_in", N.BitVector chansUsed) + , ("gthrxp_in", N.BitVector chansUsed) + , ("gtwiz_reset_clk_freerun_in", N.Clock "freerun") + , ("gtwiz_reset_all_in", N.Reset "freerun") + , ("gtwiz_reset_rx_datapath_in", N.Reset "freerun") + , ("gtwiz_userdata_tx_in", N.BitVector (chansUsed * tX_DATA_WIDTH)) + , ("txctrl2_in", N.BitVector (chansUsed * (tX_DATA_WIDTH `div` 8))) + , -- , ("gtrefclk00_in", N.Clock "refclk00" ) + ("gtrefclk0_in", N.Clock "refclk0") + ] + <> map (fmap DSL.ety) otherInps + + otherInps = + [ ("drpclk_in", gtwiz_reset_clk_freerun_in) + , ("txctrl0_in", DSL.bvLit 16 0) + , ("txctrl1_in", DSL.bvLit 16 0) + , ("gtwiz_reset_tx_pll_and_datapath_in", DSL.bvLit 1 0) + , ("gtwiz_reset_tx_datapath_in", DSL.bvLit 1 0) + , ("gtwiz_reset_rx_pll_and_datapath_in", DSL.bvLit 1 0) + , ("tx8b10ben_in", DSL.bvLit 1 1) + , ("rx8b10ben_in", DSL.bvLit 1 1) + , ("gtwiz_userclk_tx_reset_in", DSL.bvLit 1 0) + , ("gtwiz_userclk_rx_reset_in", DSL.bvLit 1 0) + , ("rxcommadeten_in", DSL.bvLit 1 1) + , ("rxmcommaalignen_in", DSL.bvLit 1 1) + , ("rxpcommaalignen_in", DSL.bvLit 1 1) + ] + compOuts = + [ ("gthtxn_out", N.BitVector chansUsed) + , ("gthtxp_out", N.BitVector chansUsed) + , ("gtwiz_userclk_tx_usrclk2_out", N.Clock "txUser2") + , ("gtwiz_userclk_rx_usrclk2_out", N.Clock "rxUser2") + , ("gtwiz_userdata_rx_out", N.BitVector (chansUsed * rX_DATA_WIDTH)) + , ("gtwiz_reset_tx_done_out", N.BitVector 1) + , ("gtwiz_reset_rx_done_out", N.BitVector 1) + , ("gtwiz_userclk_tx_active_out", N.BitVector 1) + , ("rxctrl0_out", N.BitVector 16) + , ("rxctrl1_out", N.BitVector 16) + , ("rxctrl2_out", N.BitVector 8) + , ("rxctrl3_out", N.BitVector 8) + ] + + DSL.declarationReturn bbCtx "gthCore_inst_block" $ do + DSL.compInBlock gthCoreName compInps compOuts + + let inps = zip (fst <$> compInps) args <> otherInps + outs <- mapM (uncurry DSL.declare) compOuts + DSL.instDecl + N.Empty + (Id.unsafeMake gthCoreName) + gthCoreInstName + [] + inps + (zip (fst <$> compOuts) outs) + pure [DSL.constructProduct tResult outs] gthCoreBBTF bbCtx = error ("gthCoreBBTF, bad bbCtx:\n\n" <> ppShow bbCtx) --- | Renders Tcl file conforming to the /Clash\<->Tcl API/, creating the Xilinx --- IP with @create_ip@ -gthCoreTclTF :: HasCallStack => TemplateFunction +{- | Renders Tcl file conforming to the /Clash\<->Tcl API/, creating the Xilinx +IP with @create_ip@ +-} +gthCoreTclTF :: (HasCallStack) => TemplateFunction gthCoreTclTF = TemplateFunction - [0,1] -- used arguments + [0, 1] -- used arguments (const True) gthCoreTclBBTF gthCoreTclBBTF :: - Backend s => + (Backend s) => BlackBoxContext -> State s Doc gthCoreTclBBTF bbCtx | [gthCoreName] <- N.bbQsysIncName bbCtx - , (exprToString -> Just channelNm,_,_) : (exprToString -> Just refClkNm,_,_) : _ - <- drop nConstraints (N.bbInputs bbCtx) - = pure (renderTcl [IpConfigPurpose $ ipConfig gthCoreName channelNm refClkNm ]) - where + , (exprToString -> Just channelNm, _, _) : (exprToString -> Just refClkNm, _, _) : _ <- + drop nConstraints (N.bbInputs bbCtx) = + pure (renderTcl [IpConfigPurpose $ ipConfig gthCoreName channelNm refClkNm]) + where ipConfig nm channelNm refClkNm = - (defIpConfig "gtwizard_ultrascale " "1.7" nm){ - properties = props channelNm refClkNm - } + (defIpConfig "gtwizard_ultrascale " "1.7" nm) + { properties = props channelNm refClkNm + } props channelNm refClkNm = - [ property @Text "CHANNEL_ENABLE" (fromString channelNm) - , property @Text "LOCATE_COMMON" "CORE" - , property @Text "LOCATE_IN_SYSTEM_IBERT_CORE" "NONE" - , property @Text "LOCATE_RESET_CONTROLLER" "CORE" - , property @Text "LOCATE_RX_BUFFER_BYPASS_CONTROLLER" "CORE" - , property @Text "LOCATE_RX_USER_CLOCKING" "CORE" - , property @Text "LOCATE_TX_BUFFER_BYPASS_CONTROLLER" "CORE" - , property @Text "LOCATE_TX_USER_CLOCKING" "CORE" - , property @Text "LOCATE_USER_DATA_WIDTH_SIZING" "CORE" - - , property @Text "FREERUN_FREQUENCY" "125.0" - - , property @Text "RX_REFCLK_FREQUENCY" "200" - -- .X_REFCLK_SOURCE syntax: X0Yn clk[0,1]([+,-]q - , property "RX_REFCLK_SOURCE" (BraceTcl @Text $ fromString $ unwords [channelNm, refClkNm]) - - , property @Text "RX_DATA_DECODING" "8B10B" - , property @Text "RX_INT_DATA_WIDTH" "40" - -- , property @Text "RX_JTOL_FC" "5.9988002" - , property @Text "RX_LINE_RATE" "10" - -- , property @Text "RX_MASTER_CHANNEL" "X0Y10" - , property @Text "RX_OUTCLK_SOURCE" "RXOUTCLKPMA" - - , property @Text "RX_PLL_TYPE" "CPLL" - , property @Text "RX_PPM_OFFSET" "200" - , property @Text "RX_USER_DATA_WIDTH" "64" - - , property @Text "RX_EQ_MODE" "LPM" - + [ property @Text "CHANNEL_ENABLE" (fromString channelNm) + , property @Text "LOCATE_COMMON" "CORE" + , property @Text "LOCATE_IN_SYSTEM_IBERT_CORE" "NONE" + , property @Text "LOCATE_RESET_CONTROLLER" "CORE" + , property @Text "LOCATE_RX_BUFFER_BYPASS_CONTROLLER" "CORE" + , property @Text "LOCATE_RX_USER_CLOCKING" "CORE" + , property @Text "LOCATE_TX_BUFFER_BYPASS_CONTROLLER" "CORE" + , property @Text "LOCATE_TX_USER_CLOCKING" "CORE" + , property @Text "LOCATE_USER_DATA_WIDTH_SIZING" "CORE" + , property @Text "FREERUN_FREQUENCY" "125.0" + , property @Text "RX_REFCLK_FREQUENCY" "200" + , -- .X_REFCLK_SOURCE syntax: X0Yn clk[0,1]([+,-]q + property + "RX_REFCLK_SOURCE" + (BraceTcl @Text $ fromString $ unwords [channelNm, refClkNm]) + , property @Text "RX_DATA_DECODING" "8B10B" + , property @Text "RX_INT_DATA_WIDTH" "40" + , -- , property @Text "RX_JTOL_FC" "5.9988002" + property @Text "RX_LINE_RATE" "10" + , -- , property @Text "RX_MASTER_CHANNEL" "X0Y10" + property @Text "RX_OUTCLK_SOURCE" "RXOUTCLKPMA" + , property @Text "RX_PLL_TYPE" "CPLL" + , property @Text "RX_PPM_OFFSET" "200" + , property @Text "RX_USER_DATA_WIDTH" "64" + , property @Text "RX_EQ_MODE" "LPM" , property @Text "RX_COMMA_PRESET" "K28.5" , property @Bool "RX_COMMA_P_ENABLE" True , property @Bool "RX_COMMA_M_ENABLE" True - -- , property @Text "RX_COMMA_P_VAL" "0101111100" - -- , property @Text "RX_COMMA_M_VAL" "1010000011" - -- , property @Text "RX_COMMA_MASK" "1111111111" - , property @Bool "RX_COMMA_SHOW_REALIGN_ENABLE" False - - , property @Text "TX_REFCLK_FREQUENCY" "200" - , property "TX_REFCLK_SOURCE" (BraceTcl @Text $ fromString $ unwords [channelNm, refClkNm]) - - , property @Text "TXPROGDIV_FREQ_VAL" "250" - , property @Text "TX_DATA_ENCODING" "8B10B" - , property @Text "TX_INT_DATA_WIDTH" "40" - , property @Text "TX_LINE_RATE" "10" - -- , property @Text "TX_MASTER_CHANNEL" "X0Y10" - , property @Text "TX_PLL_TYPE" "CPLL" - , property @Text "TXPROGDIV_FREQ_SOURCE" "CPLL" - , property @Text "TX_USER_DATA_WIDTH" "64" - + , -- , property @Text "RX_COMMA_P_VAL" "0101111100" + -- , property @Text "RX_COMMA_M_VAL" "1010000011" + -- , property @Text "RX_COMMA_MASK" "1111111111" + property @Bool "RX_COMMA_SHOW_REALIGN_ENABLE" False + , property @Text "TX_REFCLK_FREQUENCY" "200" + , property + "TX_REFCLK_SOURCE" + (BraceTcl @Text $ fromString $ unwords [channelNm, refClkNm]) + , property @Text "TXPROGDIV_FREQ_VAL" "250" + , property @Text "TX_DATA_ENCODING" "8B10B" + , property @Text "TX_INT_DATA_WIDTH" "40" + , property @Text "TX_LINE_RATE" "10" + , -- , property @Text "TX_MASTER_CHANNEL" "X0Y10" + property @Text "TX_PLL_TYPE" "CPLL" + , property @Text "TXPROGDIV_FREQ_SOURCE" "CPLL" + , property @Text "TX_USER_DATA_WIDTH" "64" ] - gthCoreTclBBTF bbCtx = error ("gthCoreTclBBTF, bad bbCtx:\n\n" <> ppShow bbCtx) +ibufds_gte3BBF :: (HasCallStack) => BlackBoxFunction +ibufds_gte3BBF _isD _primName _args _resTys = + let + bbMeta = emptyBlackBoxMeta{N.bbKind = N.TDecl} -ibufds_gte3BBF :: HasCallStack => BlackBoxFunction -ibufds_gte3BBF _isD _primName _args _resTys - = - let - bbMeta = emptyBlackBoxMeta { N.bbKind = N.TDecl } - - bb :: BlackBox - bb = BBFunction (show 'ibufds_gte3TF) 0 ibufds_gte3TF - in - pure $ Right (bbMeta, bb) + bb :: BlackBox + bb = BBFunction (show 'ibufds_gte3TF) 0 ibufds_gte3TF + in + pure $ Right (bbMeta, bb) -ibufds_gte3TF :: HasCallStack => TemplateFunction +ibufds_gte3TF :: (HasCallStack) => TemplateFunction ibufds_gte3TF = TemplateFunction - [0,1] + [0, 1] (const True) ibufds_gte3BBTF ibufds_gte3BBTF :: - Backend s => + (Backend s) => BlackBoxContext -> State s Doc ibufds_gte3BBTF bbCtx - | [ _knownDomain, clk] <- map fst (DSL.tInputs bbCtx) - , DataCon (Product "Clash.Signal.Internal.DiffClock" _ clkTys) _ clkEs <- DSL.eex clk - , [clkP@(Identifier _ Nothing), clkN@(Identifier _ Nothing)] <- clkEs - , [clkPTy, clkNTy] <- clkTys - = do - - ibufds_gte3InstName <- Id.makeBasic "ibufds_gte3_inst" - - let - inps = - [ - ("I", DSL.TExpr clkPTy clkP) - , ("IB", DSL.TExpr clkNTy clkN) - - -- Tied off: - , ("CEB", DSL.Low) - ] - - compOuts = - [ - ("O", Bit) - ] - attrs = - [ - ("REFCLK_EN_TX_PATH", DSL.Low) - , ("REFCLK_HROW_CK_SEL", DSL.bvLit 2 0b10) - , ("REFCLK_ICNTL_RX", DSL.bvLit 2 0b00) - ] - ibufds_gte3Name = "IBUFDS_GTE3" - DSL.declarationReturn bbCtx "ibufds_gte3_inst_block" $ do - - outs <- mapM (uncurry DSL.declare) compOuts - DSL.instDecl - N.Empty - (Id.unsafeMake ibufds_gte3Name) - ibufds_gte3InstName attrs - inps - (zip (fst <$> compOuts) outs) - pure outs - + | [_knownDomain, clk] <- map fst (DSL.tInputs bbCtx) + , DataCon (Product "Clash.Signal.Internal.DiffClock" _ clkTys) _ clkEs <- DSL.eex clk + , [clkP@(Identifier _ Nothing), clkN@(Identifier _ Nothing)] <- clkEs + , [clkPTy, clkNTy] <- clkTys = + do + ibufds_gte3InstName <- Id.makeBasic "ibufds_gte3_inst" + + let + inps = + [ ("I", DSL.TExpr clkPTy clkP) + , ("IB", DSL.TExpr clkNTy clkN) + , -- Tied off: + ("CEB", DSL.Low) + ] + + compOuts = + [ ("O", Bit) + ] + attrs = + [ ("REFCLK_EN_TX_PATH", DSL.Low) + , ("REFCLK_HROW_CK_SEL", DSL.bvLit 2 0b10) + , ("REFCLK_ICNTL_RX", DSL.bvLit 2 0b00) + ] + ibufds_gte3Name = "IBUFDS_GTE3" + DSL.declarationReturn bbCtx "ibufds_gte3_inst_block" $ do + outs <- mapM (uncurry DSL.declare) compOuts + DSL.instDecl + N.Empty + (Id.unsafeMake ibufds_gte3Name) + ibufds_gte3InstName + attrs + inps + (zip (fst <$> compOuts) outs) + pure outs ibufds_gte3BBTF bbCtx = error ("ibufds_gte3BBTF, bad bbCtx: " <> show bbCtx) diff --git a/bittide/src/Clash/Cores/Xilinx/GTH/Internal.hs b/bittide/src/Clash/Cores/Xilinx/GTH/Internal.hs index 02b577843..353c6ede4 100644 --- a/bittide/src/Clash/Cores/Xilinx/GTH/Internal.hs +++ b/bittide/src/Clash/Cores/Xilinx/GTH/Internal.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE BangPatterns #-} {-# LANGUAGE QuasiQuotes #-} @@ -9,7 +8,7 @@ module Clash.Cores.Xilinx.GTH.Internal where import Clash.Prelude -import Clash.Annotations.Primitive (hasBlackBox, Primitive (InlineYamlPrimitive)) +import Clash.Annotations.Primitive (Primitive (InlineYamlPrimitive), hasBlackBox) import Data.String.Interpolate (__i) import Clash.Cores.Xilinx.GTH.BlackBoxes @@ -25,10 +24,10 @@ type GthCore txUser2 rxUser2 refclk0 freerun txS rxS serializedData = , KnownDomain txS , KnownDomain rxS ) => + -- | channel String -> - -- ^ channel + -- | refClkSpec String -> - -- ^ refClkSpec "gthrxn_in" ::: Signal rxS serializedData -> "gthrxp_in" ::: Signal rxS serializedData -> "gtwiz_reset_clk_freerun_in" ::: Clock freerun -> @@ -57,40 +56,57 @@ gthCore !_refClkSpec !_gthrxn_in !_gthrxp_in - !_gtwiz_reset_clk_freerun_in - !_gtwiz_reset_all_in !_gtwiz_reset_rx_datapath_in !_gtwiz_userdata_tx_in !_txctrl2_in - !_gtrefclk0_in - = ( undefined, undefined, undefined, undefined - , undefined, undefined, undefined, undefined - , undefined, undefined, undefined, undefined - ) + !_gtrefclk0_in = + ( undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + ) {-# OPAQUE gthCore #-} {-# ANN gthCore hasBlackBox #-} -{-# ANN gthCore ( - let primName = 'gthCore - tfName = 'gthCoreBBF - in InlineYamlPrimitive [minBound..] [__i| +{-# ANN + gthCore + ( let primName = 'gthCore + tfName = 'gthCoreBBF + in InlineYamlPrimitive + [minBound ..] + [__i| BlackBoxHaskell: name: #{primName} templateFunction: #{tfName} workInfo: Always - |]) #-} + |] + ) + #-} -ibufds_gte3 :: KnownDomain dom => DiffClock dom -> Clock dom +ibufds_gte3 :: (KnownDomain dom) => DiffClock dom -> Clock dom ibufds_gte3 !_clk = clockGen {-# OPAQUE ibufds_gte3 #-} {-# ANN ibufds_gte3 hasBlackBox #-} -{-# ANN ibufds_gte3 ( - let primName = 'ibufds_gte3 - tfName = 'ibufds_gte3BBF - in InlineYamlPrimitive [minBound..] [__i| +{-# ANN + ibufds_gte3 + ( let primName = 'ibufds_gte3 + tfName = 'ibufds_gte3BBF + in InlineYamlPrimitive + [minBound ..] + [__i| BlackBoxHaskell: name: #{primName} templateFunction: #{tfName} workInfo: Always - |]) #-} + |] + ) + #-} diff --git a/bittide/src/Clash/Cores/Xilinx/Xpm/Cdc/Handshake/Extra.hs b/bittide/src/Clash/Cores/Xilinx/Xpm/Cdc/Handshake/Extra.hs index 044683d24..46238c420 100644 --- a/bittide/src/Clash/Cores/Xilinx/Xpm/Cdc/Handshake/Extra.hs +++ b/bittide/src/Clash/Cores/Xilinx/Xpm/Cdc/Handshake/Extra.hs @@ -10,17 +10,19 @@ import Data.Maybe import Bittide.Extra.Maybe --- | Reliable CDC component based on `xpmCdcHandshakeMaybe` without backpressure and --- with limited throughput. Data will be lost if the `src` domain provides more inputs --- than the circuit can handle. Useful for low granularity synchronization, --- in our case: synchronizing datacounts. +{- | Reliable CDC component based on `xpmCdcHandshakeMaybe` without backpressure and +with limited throughput. Data will be lost if the `src` domain provides more inputs +than the circuit can handle. Useful for low granularity synchronization, +in our case: synchronizing datacounts. +-} xpmCdcMaybeLossy :: ( KnownDomain src , KnownDomain dst , BitPack a , NFDataX a , 1 <= BitSize a - , BitSize a <= 1024) => + , BitSize a <= 1024 + ) => -- | Source clock Clock src -> -- | Destination clock @@ -31,8 +33,14 @@ xpmCdcMaybeLossy :: Signal dst (Maybe a) xpmCdcMaybeLossy clkSrc clkDst maybeInp = mux (isRising clkDst noReset enableGen False dstAck) dstOut (pure Nothing) where - srcReg = regEn clkSrc noReset enableGen Nothing - (srcRcv .||. srcRegEmpty) $ mux (srcRegEmpty .&&. fmap not srcRcv) maybeInp (pure Nothing) + srcReg = + regEn + clkSrc + noReset + enableGen + Nothing + (srcRcv .||. srcRegEmpty) + $ mux (srcRegEmpty .&&. fmap not srcRcv) maybeInp (pure Nothing) srcRegEmpty = isNothing <$> srcReg (srcRcv, dstOut) = xpmCdcHandshakeMaybe clkSrc clkDst srcReg (isJust <$> dstOut) @@ -45,7 +53,8 @@ xpmCdcHandshakeMaybe :: , BitPack a , NFDataX a , 1 <= BitSize a - , BitSize a <= 1024) => + , BitSize a <= 1024 + ) => -- | Source clock Clock src -> -- | Destination clock @@ -60,4 +69,5 @@ xpmCdcHandshakeMaybe :: (Signal src Bool, Signal dst (Maybe a)) xpmCdcHandshakeMaybe clkSrc clkDst srcIn dstAck = (srcRcv, orNothing <$> dstReq <*> dstOut) where - (dstOut, dstReq, srcRcv) = xpmCdcHandshake clkSrc clkDst (fromMaybe (unpack 0) <$> srcIn) (isJust <$> srcIn) dstAck + (dstOut, dstReq, srcRcv) = + xpmCdcHandshake clkSrc clkDst (fromMaybe (unpack 0) <$> srcIn) (isJust <$> srcIn) dstAck diff --git a/bittide/src/Clash/Explicit/Reset/Extra.hs b/bittide/src/Clash/Explicit/Reset/Extra.hs index d475afa49..3ee01d7f0 100644 --- a/bittide/src/Clash/Explicit/Reset/Extra.hs +++ b/bittide/src/Clash/Explicit/Reset/Extra.hs @@ -4,15 +4,17 @@ module Clash.Explicit.Reset.Extra where -import Clash.Explicit.Prelude import Clash.Cores.Xilinx.Xpm.Cdc.Single +import Clash.Explicit.Prelude --- | Configuration value to indicate whether resets should be asserted or --- deasserted. Used throughout this module. +{- | Configuration value to indicate whether resets should be asserted or +deasserted. Used throughout this module. +-} data Asserted = Asserted | Deasserted --- | A reset synchronizer based on 'xpmCdcSingle'. I.e., a reset synchronizer that --- is recognized by Vivado as a safe CDC construct. +{- | A reset synchronizer based on 'xpmCdcSingle'. I.e., a reset synchronizer that +is recognized by Vivado as a safe CDC construct. +-} xpmResetSynchronizer :: (HasSynchronousReset src, KnownDomain dst) => -- | Initial value of registers in 'xpmCdcSingle' @@ -23,24 +25,25 @@ xpmResetSynchronizer :: Reset dst xpmResetSynchronizer asserted clkSrc clkDest = case asserted of - Asserted -> unsafeFromActiveLow . go . unsafeToActiveLow + Asserted -> unsafeFromActiveLow . go . unsafeToActiveLow Deasserted -> unsafeFromActiveHigh . go . unsafeToActiveHigh where go = xpmCdcSingle clkSrc clkDest --- | Like 'delay', but for 'Reset'. Can be used to filter glitches caused by --- combinatorial logic. +{- | Like 'delay', but for 'Reset'. Can be used to filter glitches caused by +combinatorial logic. +-} delayReset :: - HasSynchronousReset dom => + (HasSynchronousReset dom) => -- | Initial and reset value of register Asserted -> Clock dom -> Reset dom -> Reset dom delayReset asserted clk = - unsafeFromActiveHigh - . delay clk enableGen assertedBool - . unsafeToActiveHigh + unsafeFromActiveHigh + . delay clk enableGen assertedBool + . unsafeToActiveHigh where assertedBool = case asserted of diff --git a/bittide/src/Clash/Sized/Extra.hs b/bittide/src/Clash/Sized/Extra.hs index f4fce0c5c..76a45efb0 100644 --- a/bittide/src/Clash/Sized/Extra.hs +++ b/bittide/src/Clash/Sized/Extra.hs @@ -11,16 +11,17 @@ import Clash.Prelude -} -- | Safe 'Unsigned' to 'Signed' conversion -unsignedToSigned :: forall n. KnownNat n => Unsigned n -> Signed (n + 1) +unsignedToSigned :: forall n. (KnownNat n) => Unsigned n -> Signed (n + 1) unsignedToSigned n = bitCoerce (zeroExtend n) --- | Combine two 'Unsigned's by concatenating them together. I.e., the first --- argument is prepended to the second. --- --- >>> pack (concatUnsigneds (0b1100 :: Unsigned 4) (0b1111 :: Unsigned 4)) --- 0b1100_1111 +{- | Combine two 'Unsigned's by concatenating them together. I.e., the first +argument is prepended to the second. + +>>> pack (concatUnsigneds (0b1100 :: Unsigned 4) (0b1111 :: Unsigned 4)) +0b1100_1111 +-} concatUnsigneds :: - forall a b . + forall a b. (KnownNat a, KnownNat b) => -- | Most significant bits of result Unsigned a -> diff --git a/bittide/src/Data/Constraint/Nat/Extra.hs b/bittide/src/Data/Constraint/Nat/Extra.hs index 31c8fef71..f94c8198e 100644 --- a/bittide/src/Data/Constraint/Nat/Extra.hs +++ b/bittide/src/Data/Constraint/Nat/Extra.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {- NOTE [constraint solver addition] @@ -11,37 +10,35 @@ solved by the constraint solver. Machine verifiable Agda proofs of the properties claimed in this file can be found in @bittide/proofs/TypeNatProofs.agda@ -} - {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Constraint.Nat.Extra - ( module Data.Constraint.Nat.Extra - , Data.Constraint.Dict(..) - ) where +module Data.Constraint.Nat.Extra ( + module Data.Constraint.Nat.Extra, + Data.Constraint.Dict (..), +) where import Data.Constraint +import Data.Ord ((<=)) import Data.Proxy +import Data.Type.Bool (If) import Data.Type.Equality +import GHC.Num ((-)) import GHC.TypeLits.Extra import GHC.TypeLits.KnownNat import GHC.TypeNats import Unsafe.Coerce -import GHC.Num ((-)) -import Data.Ord ((<=)) -import Data.Type.Bool (If) type family OneMore (n :: Nat) :: Nat where OneMore 0 = 0 OneMore _ = 1 -instance KnownNat n => KnownNat1 $(nameToSymbol ''OneMore) n where +instance (KnownNat n) => KnownNat1 $(nameToSymbol ''OneMore) n where natSing1 = case natVal (Proxy @n) of 0 -> SNatKn 0 _ -> SNatKn 1 @@ -59,69 +56,75 @@ instance (KnownNat a, KnownNat b) => KnownNat2 $(nameToSymbol ''SatSubZero) a b a = natVal (Proxy @a) b = natVal (Proxy @b) z = if a <= b then 0 else a - b - in + in SNatKn z {-# INLINE natSing2 #-} -- | b <= ceiling(b/a)*a -timesDivRU :: forall a b . (1 <= a) => Dict (b <= (Div (b + (a - 1)) a * a)) +timesDivRU :: forall a b. (1 <= a) => Dict (b <= (Div (b + (a - 1)) a * a)) timesDivRU = unsafeCoerce (Dict :: Dict (0 <= 0)) --- | Implements logarithmic product rule. Currently hardcoded for specific --- constants, which we might relax in the future. +{- | Implements logarithmic product rule. Currently hardcoded for specific +constants, which we might relax in the future. +-} clogProductRule :: (1 <= n) => CLog 2 (n * 2) :~: (CLog 2 n + 1) clogProductRule = unsafeCoerce Refl --- | Postulates that multiplying some number /a/ by some constant /b/, and --- subsequently dividing that result by /b/ equals /a/. -cancelMulDiv :: forall a b . (1 <= b) => Dict (DivRU (a * b) b ~ a) +{- | Postulates that multiplying some number /a/ by some constant /b/, and +subsequently dividing that result by /b/ equals /a/. +-} +cancelMulDiv :: forall a b. (1 <= b) => Dict (DivRU (a * b) b ~ a) cancelMulDiv = unsafeCoerce (Dict :: Dict (0 ~ 0)) --- | Postulates that adding a constant less than the denominator does not --- change the result (for the given specific context). +{- | Postulates that adding a constant less than the denominator does not +change the result (for the given specific context). +-} divWithRemainder :: forall a b c. (1 <= b, c <= (b - 1)) => Dict (Div ((a * b) + c) b ~ a) divWithRemainder = unsafeCoerce (Dict :: Dict (0 ~ 0)) --- | Postulates that a part is less than or equal to a sum parts, in context --- of 'Max's left argument. +{- | Postulates that a part is less than or equal to a sum parts, in context +of 'Max's left argument. +-} leMaxLeft :: forall a b c. Dict (a <= Max (a + c) b) leMaxLeft = unsafeCoerce (Dict :: Dict (0 <= 0)) -- | If @c <= a@ and @c <= b@, then @c <= Max a b@ -lessThanMax :: forall a b c . (c <= a, c <= b) => Dict (c <= Max a b) +lessThanMax :: forall a b c. (c <= a, c <= b) => Dict (c <= Max a b) lessThanMax = unsafeCoerce (Dict :: Dict (0 <= 0)) --- | Postulates that a part is less than or equal to a sum parts, in context --- of 'Max's right argument. +{- | Postulates that a part is less than or equal to a sum parts, in context +of 'Max's right argument. +-} leMaxRight :: forall a b c. Dict (b <= Max a (b + c)) leMaxRight = unsafeCoerce (Dict :: Dict (0 <= 0)) -- | if (1 <= a) and (1 <= b) then (1 <= DivRU a b) -strictlyPositiveDivRu :: forall a b . (1 <= a, 1 <= b) => Dict (1 <= DivRU a b) +strictlyPositiveDivRu :: forall a b. (1 <= a, 1 <= b) => Dict (1 <= DivRU a b) strictlyPositiveDivRu = unsafeCoerce (Dict :: Dict (0 <= 0)) --- | Euclid's third axiom: /If equals be subtracted from equals, the remainders --- are equal/. -euclid3 :: forall a b c . (a + b <= c) => Dict (a <= c - b) +{- | Euclid's third axiom: /If equals be subtracted from equals, the remainders +are equal/. +-} +euclid3 :: forall a b c. (a + b <= c) => Dict (a <= c - b) euclid3 = unsafeCoerce (Dict :: Dict (0 <= 0)) -- | if (2 <= n) holds, then (1 <= CLog 2 n) also holds. -oneLeCLog2n :: forall n . (2 <= n) => Dict (1 <= CLog 2 n) +oneLeCLog2n :: forall n. (2 <= n) => Dict (1 <= CLog 2 n) oneLeCLog2n = unsafeCoerce (Dict :: Dict (0 <= 0)) -- | If @1 <= m@ and @n + m <= u@, then @1 + n <= u@ -useLowerLimit :: forall n m u . (1 <= m, n + m <= u) => Dict (1 + n <= u) +useLowerLimit :: forall n m u. (1 <= m, n + m <= u) => Dict (1 + n <= u) useLowerLimit = unsafeCoerce (Dict :: Dict (0 <= 0)) -- | If @1 <= n@ and @1 <= m@, then @1 <= Div n m + OneMore (Mod n m)@ -oneMore :: forall n m . (1 <= n, 1 <= m) => Dict (1 <= Div n m + OneMore (Mod n m)) +oneMore :: forall n m. (1 <= n, 1 <= m) => Dict (1 <= Div n m + OneMore (Mod n m)) oneMore = unsafeCoerce (Dict :: Dict (0 <= 0)) -- | If @1 <= n@ and @n <= m@, then @Div n m + OneMore (Mod n m) == 1@ -isOne :: forall n m . (1 <= n, n <= m) => Dict (Div n m + OneMore (Mod n m) ~ 1) +isOne :: forall n m. (1 <= n, n <= m) => Dict (Div n m + OneMore (Mod n m) ~ 1) isOne = unsafeCoerce (Dict :: Dict (0 ~ 0)) -- | Postulates that @SatSubZero a b + Min a b == a@ @@ -136,7 +139,8 @@ minLeq = unsafeCoerce (Dict :: Dict (0 <= 0)) maxGeqPlus :: forall a b c. Dict (a <= Max a b + c) maxGeqPlus = unsafeCoerce (Dict :: Dict (0 <= 0)) --- | Postulates that multiplying two numbers that are greater than 1 will --- result in a number that is greater than 1. -leMult :: forall a b . (1 <= a, 1 <= b) => Dict (1 <= a * b) +{- | Postulates that multiplying two numbers that are greater than 1 will +result in a number that is greater than 1. +-} +leMult :: forall a b. (1 <= a, 1 <= b) => Dict (1 <= a * b) leMult = unsafeCoerce (Dict :: Dict (0 <= 0)) diff --git a/bittide/src/System/IO/Temp/Extra.hs b/bittide/src/System/IO/Temp/Extra.hs index a2f2d87d5..1012e2b27 100644 --- a/bittide/src/System/IO/Temp/Extra.hs +++ b/bittide/src/System/IO/Temp/Extra.hs @@ -1,7 +1,7 @@ -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 -module System.IO.Temp.Extra(withTempBinaryFile) where +module System.IO.Temp.Extra (withTempBinaryFile) where import Prelude @@ -11,9 +11,10 @@ import System.IO import qualified Control.Monad.Catch as MC --- | Create, open, and use a temporary binary file in the given directory. --- --- The temp file is deleted after use. +{- | Create, open, and use a temporary binary file in the given directory. + +The temp file is deleted after use. +-} withTempBinaryFile :: (MonadIO m, MC.MonadMask m) => -- | Parent directory to create the file in @@ -30,5 +31,5 @@ withTempBinaryFile tmpDir template action = (\(name, handle) -> liftIO (hClose handle >> ignoringIOErrors (removeFile name))) (uncurry action) -ignoringIOErrors :: MC.MonadCatch m => m () -> m () +ignoringIOErrors :: (MC.MonadCatch m) => m () -> m () ignoringIOErrors ioe = ioe `MC.catch` (\e -> const (return ()) (e :: IOError)) diff --git a/bittide/tests/Tests/Axi4.hs b/bittide/tests/Tests/Axi4.hs index c6b833421..fba98d52c 100644 --- a/bittide/tests/Tests/Axi4.hs +++ b/bittide/tests/Tests/Axi4.hs @@ -6,9 +6,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-type-defaults #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} {-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} @@ -17,8 +16,8 @@ module Tests.Axi4 where -import Clash.Prelude import Clash.Explicit.Prelude (noReset) +import Clash.Prelude import Clash.Hedgehog.Sized.Unsigned import Data.Either @@ -44,19 +43,40 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range tests :: TestTree -tests = testGroup "Tests.Axi4" - [ testPropertyNamed - "Read Axi4 Stream packets via Wishbone" "prop_wbAxisRxBufferReadStreams" - prop_wbAxisRxBufferReadStreams - , testPropertyNamed "Various operation on Axi4StreamM2S: splitAxi4Stream combineAxi4Stream packAxi4Stream" "prop_axiOperations" prop_axiOperations - , testPropertyNamed "Packet conversion utilies" "prop_packetConversions" prop_packetConversions - , testPropertyNamed "Axi4StreamPacketFifo" "prop_axi4StreamPacketFifo" prop_axi4StreamPacketFifo - , testPropertyNamed "Axi4StreamPacketFifo produces uninterrupted packets" "prop_axi4StreamPacketFifo_Uninterrupted" prop_axi4StreamPacketFifo_Uninterrupted - , testPropertyNamed "axiStreamToByteStream" "prop_axiStreamToByteStream" prop_axiStreamToByteStream - , testPropertyNamed "axiStreamFromByteStream " "prop_axiStreamFromByteStream" prop_axiStreamFromByteStream - , testPropertyNamed "packAxi4Stream" "prop_packAxi4Stream" prop_packAxi4Stream - , testPropertyNamed "prop_axiPacking" "prop_axiPacking" prop_axiPacking - ] +tests = + testGroup + "Tests.Axi4" + [ testPropertyNamed + "Read Axi4 Stream packets via Wishbone" + "prop_wbAxisRxBufferReadStreams" + prop_wbAxisRxBufferReadStreams + , testPropertyNamed + "Various operation on Axi4StreamM2S: splitAxi4Stream combineAxi4Stream packAxi4Stream" + "prop_axiOperations" + prop_axiOperations + , testPropertyNamed + "Packet conversion utilies" + "prop_packetConversions" + prop_packetConversions + , testPropertyNamed + "Axi4StreamPacketFifo" + "prop_axi4StreamPacketFifo" + prop_axi4StreamPacketFifo + , testPropertyNamed + "Axi4StreamPacketFifo produces uninterrupted packets" + "prop_axi4StreamPacketFifo_Uninterrupted" + prop_axi4StreamPacketFifo_Uninterrupted + , testPropertyNamed + "axiStreamToByteStream" + "prop_axiStreamToByteStream" + prop_axiStreamToByteStream + , testPropertyNamed + "axiStreamFromByteStream " + "prop_axiStreamFromByteStream" + prop_axiStreamFromByteStream + , testPropertyNamed "packAxi4Stream" "prop_packAxi4Stream" prop_packAxi4Stream + , testPropertyNamed "prop_axiPacking" "prop_axiPacking" prop_axiPacking + ] -- This test only checks that the data and position bytes are not changed by the component, -- _tdest, _tid and _tuser are not checked. @@ -68,8 +88,15 @@ prop_axiStreamToByteStream = model = L.concatMap (catMaybes . packetToAxiStream d1) . axiStreamToPackets - packetGen = catMaybes <$> genRandomAxiPacket d4 d0 d0 - [NullByte, DataByte, PositionByte] (Range.linear 0 16) (pure ()) + packetGen = + catMaybes + <$> genRandomAxiPacket + d4 + d0 + d0 + [NullByte, DataByte, PositionByte] + (Range.linear 0 16) + (pure ()) gen = L.concat <$> Gen.list (Range.linear 0 3) packetGen prop expected sampled = do @@ -93,47 +120,71 @@ prop_axi4StreamPacketFifo = where impl = wcre @System $ axiStreamPacketFifo d8 d64 - packetGen = catMaybes <$> genRandomAxiPacket d4 d0 d0 - [NullByte, DataByte, PositionByte] (Range.linear 0 32) (pure ()) + packetGen = + catMaybes + <$> genRandomAxiPacket + d4 + d0 + d0 + [NullByte, DataByte, PositionByte] + (Range.linear 0 32) + (pure ()) gen = L.concat <$> Gen.list (Range.linear 0 10) packetGen --- | Generate a 'axiStreamFromByteStream' component with variable output bus width --- and test if a stream of multiple generated 'Packet's can be routed through it --- without being changed. +{- | Generate a 'axiStreamFromByteStream' component with variable output bus width +and test if a stream of multiple generated 'Packet's can be routed through it +without being changed. +-} prop_axi4StreamPacketFifo_Uninterrupted :: Property prop_axi4StreamPacketFifo_Uninterrupted = property $ do busWidth <- forAll $ Gen.integral $ Range.linear 1 8 extraFifoDepth <- forAll $ Gen.integral $ Range.linear 2 64 - case - ( TN.someNatVal $ fromIntegral busWidth - ,TN.someNatVal $ fromIntegral extraFifoDepth - ) of + case ( TN.someNatVal $ fromIntegral busWidth + , TN.someNatVal $ fromIntegral extraFifoDepth + ) of ( SomeNat (Proxy :: Proxy busWidth) - ,SomeNat (Proxy :: Proxy extraFifoDepth) - ) -> do - let packetGen = genRandomAxiPacket (SNat @busWidth) d0 d0 - [NullByte, DataByte, PositionByte] (Range.linear 0 (extraFifoDepth - 2)) (pure ()) - inputData <- forAll (L.concat <$> Gen.list (Range.linear 0 10) packetGen) - let - conf = SimulationConfig 0 100 True - simOut = withClockResetEnable @System clockGen noReset enableGen - $ sampleC conf $ axiStreamPacketFifo d2 (SNat @(2 + extraFifoDepth)) <| driveC conf inputData - - footnote $ "inputData: " <> show inputData - footnote $ "simOut: " <> show simOut - assert $ unInterruptedAxi4Packets simOut - --- | Verify that the 'axiStreamFromByteStream' component does not change the content of the stream --- when converting 1 byte wide transfers to 4 byte wide transfers. + , SomeNat (Proxy :: Proxy extraFifoDepth) + ) -> do + let packetGen = + genRandomAxiPacket + (SNat @busWidth) + d0 + d0 + [NullByte, DataByte, PositionByte] + (Range.linear 0 (extraFifoDepth - 2)) + (pure ()) + inputData <- forAll (L.concat <$> Gen.list (Range.linear 0 10) packetGen) + let + conf = SimulationConfig 0 100 True + simOut = + withClockResetEnable @System clockGen noReset enableGen + $ sampleC conf + $ axiStreamPacketFifo d2 (SNat @(2 + extraFifoDepth)) + <| driveC conf inputData + + footnote $ "inputData: " <> show inputData + footnote $ "simOut: " <> show simOut + assert $ unInterruptedAxi4Packets simOut + +{- | Verify that the 'axiStreamFromByteStream' component does not change the content of the stream +when converting 1 byte wide transfers to 4 byte wide transfers. +-} prop_axiStreamFromByteStream :: Property prop_axiStreamFromByteStream = propWithModel defExpectOptions gen model impl prop where impl = wcre @System $ axiUserMapC (const ()) <| axiStreamFromByteStream model = L.concatMap (catMaybes . packetToAxiStream d4) . axiStreamToPackets - packetGen = catMaybes <$> genRandomAxiPacket d1 d0 d0 - [NullByte, DataByte, PositionByte] (Range.linear 0 16) (pure ()) + packetGen = + catMaybes + <$> genRandomAxiPacket + d1 + d0 + d0 + [NullByte, DataByte, PositionByte] + (Range.linear 0 16) + (pure ()) gen = L.concat <$> Gen.list (Range.linear 0 3) packetGen @@ -155,8 +206,10 @@ prop_axiStreamFromByteStream = propWithModel defExpectOptions gen model impl pro prop_packAxi4Stream :: Property prop_packAxi4Stream = property $ do -- A transaction can only contain null bytes and be packed if _tlast is True - axiWithNulls <- forAll $ genAxisM2S d8 d0 d0 [NullByte, DataByte, PositionByte] [True] $ pure () - axiWithoutNulls <- forAll $ genAxisM2S d8 d0 d0 [DataByte, PositionByte] [True, False] $ pure () + axiWithNulls <- + forAll $ genAxisM2S d8 d0 d0 [NullByte, DataByte, PositionByte] [True] $ pure () + axiWithoutNulls <- + forAll $ genAxisM2S d8 d0 d0 [DataByte, PositionByte] [True, False] $ pure () let resultWithNulls = packAxi4Stream axiWithNulls resultWithoutNulls = packAxi4Stream axiWithoutNulls @@ -165,17 +218,19 @@ prop_packAxi4Stream = property $ do assert (isPackedTransfer resultWithNulls) assert (isPackedTransfer resultWithoutNulls) --- | Extract the data and strobe bytes. 'Nothing' if the corresponding keep bit --- is low, 'Just' if the keep bit is high. +{- | Extract the data and strobe bytes. 'Nothing' if the corresponding keep bit +is low, 'Just' if the keep bit is high. +-} catKeepBytes :: - KnownNat (DataWidth conf) => + (KnownNat (DataWidth conf)) => Axi4StreamM2S conf userType -> Vec (DataWidth conf) (Maybe (Unsigned 8, Bool)) catKeepBytes Axi4StreamM2S{..} = orNothing <$> _tkeep <*> zip _tdata _tstrb prop_axiOperations :: Property prop_axiOperations = property $ do - axi <- forAll $ genAxisM2S d4 d0 d0 [NullByte, DataByte, PositionByte] [True, False] $ pure () + axi <- + forAll $ genAxisM2S d4 d0 d0 [NullByte, DataByte, PositionByte] [True, False] $ pure () let keepBytesA = catMaybes $ toList $ catKeepBytes axi keepBytesB = catMaybes $ toList $ catKeepBytes (packAxi4Stream axi) @@ -184,13 +239,13 @@ prop_axiOperations = property $ do keepBytesA === keepBytesB -- Differentiate between empty and non-empty transfers if all not (_tkeep axi) && not (_tlast axi) - then ( do - (Nothing, Nothing) === splitConcatA - Nothing === uncurry (<|>) splitConcatA - Nothing === uncurry (flip (<|>)) splitConcatA + then + ( do + (Nothing, Nothing) === splitConcatA + Nothing === uncurry (<|>) splitConcatA + Nothing === uncurry (flip (<|>)) splitConcatA ) - else - do + else do (Just axi, Nothing) === splitConcatA Just axi === uncurry (<|>) splitConcatA Just axi === uncurry (flip (<|>)) splitConcatA @@ -202,9 +257,15 @@ prop_axiPacking = propWithModel defExpectOptions gen model impl prop where impl = wcre @System axiPacking model = id -- - - packetGen = catMaybes <$> genRandomAxiPacket d1 d0 d0 - [NullByte, DataByte, PositionByte] (Range.linear 0 32) (pure ()) + packetGen = + catMaybes + <$> genRandomAxiPacket + d1 + d0 + d0 + [NullByte, DataByte, PositionByte] + (Range.linear 0 32) + (pure ()) gen = L.concat <$> Gen.list (Range.linear 0 3) packetGen @@ -225,14 +286,25 @@ prop_axiPacking = propWithModel defExpectOptions gen model impl prop prop_wbAxisRxBufferReadStreams :: Property prop_wbAxisRxBufferReadStreams = property $ do - let packetGen = Gen.filter (byteTypeFilter conditions . catMaybes) $ genRandomAxiPacket d4 d0 d0 - [NullByte, DataByte] (Range.linear 0 16) (pure ()) + let packetGen = + Gen.filter (byteTypeFilter conditions . catMaybes) + $ genRandomAxiPacket + d4 + d0 + d0 + [NullByte, DataByte] + (Range.linear 0 16) + (pure ()) inputData <- forAll (L.concat <$> Gen.list (Range.linear 0 3) packetGen) extraBufferBytes <- forAll $ Gen.integral (Range.linear 31 31) case TN.someNatVal extraBufferBytes of SomeNat (Proxy :: Proxy extraBufferBytes) -> do - let transfers = catMaybes $ wcre - $ sampleC conf $ tb (SNat @(1 + extraBufferBytes)) <| driveC conf inputData + let transfers = + catMaybes + $ wcre + $ sampleC conf + $ tb (SNat @(1 + extraBufferBytes)) + <| driveC conf inputData footnote $ "transfers: " <> show transfers footnote $ "inputData: " <> show inputData axiStreamToPackets (catMaybes inputData) === axiStreamToPackets transfers @@ -242,11 +314,12 @@ prop_wbAxisRxBufferReadStreams = property $ do , not . hasLeadingNullBytes ] conf = SimulationConfig 0 500 False - tb :: (1 <= bufferBytes, HiddenClockResetEnable System) => + tb :: + (1 <= bufferBytes, HiddenClockResetEnable System) => SNat bufferBytes -> Circuit - (Axi4Stream System ('Axi4StreamConfig 4 0 0 ) ()) - (Axi4Stream System ('Axi4StreamConfig 4 0 0 ) ()) + (Axi4Stream System ('Axi4StreamConfig 4 0 0) ()) + (Axi4Stream System ('Axi4StreamConfig 4 0 0) ()) tb bufferBytes = circuit $ \axiIn0 -> do axiIn1 <- axiUserMapC (const False) -< axiIn0 _status <- wbAxisRxBufferCircuit @System @32 bufferBytes -< (wb, axiIn1) @@ -255,16 +328,18 @@ prop_wbAxisRxBufferReadStreams = property $ do prop_packetConversions :: Property prop_packetConversions = property $ do - packets <- forAll - $ Gen.list (Range.linear 1 4) - $ Gen.list (Range.linear 1 128) - $ genUnsigned Range.constantBounded + packets <- + forAll + $ Gen.list (Range.linear 1 4) + $ Gen.list (Range.linear 1 128) + $ genUnsigned Range.constantBounded let transfers = fmap (packetToAxiStream d4) packets footnote $ "transfers:" <> show transfers packets === axiStreamToPackets (L.concatMap catMaybes transfers) --- | Force all invalid bytes to zero. This is useful for a poor man's version --- of '=='. +{- | Force all invalid bytes to zero. This is useful for a poor man's version +of '=='. +-} forceKeepLowZero :: Axi4StreamM2S conf userType -> Axi4StreamM2S conf userType forceKeepLowZero a = a{_tdata = zipWith (\k d -> if k then d else 0) (_tkeep a) (_tdata a)} diff --git a/bittide/tests/Tests/Axi4/Generators.hs b/bittide/tests/Tests/Axi4/Generators.hs index fcfe550dc..6d8152aae 100644 --- a/bittide/tests/Tests/Axi4/Generators.hs +++ b/bittide/tests/Tests/Axi4/Generators.hs @@ -1,10 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- SPDX-FileCopyrightText: 2023 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} module Tests.Axi4.Generators where @@ -22,17 +21,19 @@ import Test.Tasty.Hedgehog import Tests.Axi4.Properties import Tests.Axi4.Types +import qualified Data.List as L import qualified GHC.TypeNats as TN import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import qualified Data.List as L import qualified Hedgehog.Internal.Property as H +import qualified Hedgehog.Range as Range tests :: TestTree -tests = testGroup "Axi4Stream Generators" - [ testProperty "genAxisM2S" prop_genAxisM2S - , testProperty "genRandomAxiPacket" prop_genRandomAxiPacket - ] +tests = + testGroup + "Axi4Stream Generators" + [ testProperty "genAxisM2S" prop_genAxisM2S + , testProperty "genRandomAxiPacket" prop_genRandomAxiPacket + ] -- | Generates a directed Axi4StreamM2S transaction. genAxisM2S :: @@ -50,11 +51,11 @@ genAxisM2S :: Gen userType -> Gen (Axi4StreamM2S ('Axi4StreamConfig dataWidth idWidth destWidth) userType) genAxisM2S SNat SNat SNat byteTypes lastValues genUser = do - bytes <- genVec $ Gen.choice $ fmap pure byteTypes + bytes <- genVec $ Gen.choice $ fmap pure byteTypes let (_tkeep, _tstrb) = unzip $ map getKeepStrobe bytes _tdata <- genVec $ genUnsigned Range.constantBounded _tlast <- Gen.choice $ fmap pure lastValues - _tid <- genUnsigned Range.constantBounded + _tid <- genUnsigned Range.constantBounded _tdest <- genUnsigned Range.constantBounded _tuser <- genUser pure $ Axi4StreamM2S{..} @@ -73,9 +74,17 @@ prop_genAxisM2S = property $ do let axiBytes = getByteType <$> getTransferBytes axi cover 40 "tlast" (_tlast axi) cover 40 "not tlast" (not $ _tlast axi) - mapM_ (\ byte -> cover 25 (H.LabelName $ "One or more " <> show byte) (isJust $ elemIndex byte axiBytes)) byteTypes - mapM_ (\ byte -> cover 1 (H.LabelName $ "All " <> show byte) (all (== byte) axiBytes)) byteTypes - mapM_ (\ byte -> cover 1 (H.LabelName $ "No " <> show byte) (byte `notElem` axiBytes)) byteTypes + mapM_ + ( \byte -> + cover 25 (H.LabelName $ "One or more " <> show byte) (isJust $ elemIndex byte axiBytes) + ) + byteTypes + mapM_ + (\byte -> cover 1 (H.LabelName $ "All " <> show byte) (all (== byte) axiBytes)) + byteTypes + mapM_ + (\byte -> cover 1 (H.LabelName $ "No " <> show byte) (byte `notElem` axiBytes)) + byteTypes assert (all (`L.elem` byteTypes) $ toList axiBytes) assert (_tlast axi `L.elem` lastValues) @@ -84,8 +93,9 @@ data PacketDensity | Dense deriving (Show, Eq) --- | Generate a list of Axi4StreamM2S transactions that form a single packet, only the last transaction --- will have _tlast set to True. The packet +{- | Generate a list of Axi4StreamM2S transactions that form a single packet, only the last transaction +will have _tlast set to True. The packet +-} genRandomAxiPacket :: -- | Data width of the Axi4StreamM2S transaction SNat dataWidth -> @@ -102,7 +112,8 @@ genRandomAxiPacket :: -- | Generator for a list of transactions representing a packet Gen [Maybe (Axi4StreamM2S ('Axi4StreamConfig dataWidth idWidth destWidth) userType)] genRandomAxiPacket SNat SNat SNat byteTypes range genUser = do - packetInit <- Gen.list range (Gen.maybe $ genAxisM2S SNat SNat SNat byteTypes [False] genUser) + packetInit <- + Gen.list range (Gen.maybe $ genAxisM2S SNat SNat SNat byteTypes [False] genUser) packetLast <- genAxisM2S SNat SNat SNat byteTypes [True] genUser pure (L.tail $ packetInit <> [Just packetLast]) @@ -113,7 +124,9 @@ prop_genRandomAxiPacket = property $ do (SomeNat (Proxy :: Proxy dataWidth)) -> do let byteTypes = [NullByte, DataByte, PositionByte] - transfers <- forAll $ genRandomAxiPacket (SNat @dataWidth) d0 d0 byteTypes (Range.constant 1 16) (pure ()) + transfers <- + forAll + $ genRandomAxiPacket (SNat @dataWidth) d0 d0 byteTypes (Range.constant 1 16) (pure ()) let packet = catMaybes transfers axiBytes = getPacketByteTypes packet diff --git a/bittide/tests/Tests/Axi4/Properties.hs b/bittide/tests/Tests/Axi4/Properties.hs index bb3250b17..6a7e30db0 100644 --- a/bittide/tests/Tests/Axi4/Properties.hs +++ b/bittide/tests/Tests/Axi4/Properties.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} module Tests.Axi4.Properties where @@ -9,22 +8,24 @@ module Tests.Axi4.Properties where import Clash.Prelude import Protocols.Axi4.Stream -import Tests.Axi4.Types import qualified Data.List as L -import qualified Test.Tasty.HUnit as HU -import Test.Tasty import Data.Maybe +import Test.Tasty +import qualified Test.Tasty.HUnit as HU +import Tests.Axi4.Types tests :: TestTree -tests = testGroup "Tests.Axi4.Properties" - [ HU.testCase "case_isPackedAxi4StreamPacket" case_isPackedAxi4StreamPacket - , HU.testCase "case_hasLeadingNullBytes" case_hasLeadingNullBytes - , HU.testCase "case_hasTrailingNullBytes" case_hasTrailingNullBytes - , HU.testCase "case_isSinglePacket" case_isSinglePacket - , HU.testCase "case_isStrictlySparseAxi4StreamPacket" case_isStrictlySparseAxi4StreamPacket - , HU.testCase "case_isUnalignedAxi4StreamPacket" case_isUnalignedAxi4StreamPacket - , HU.testCase "case_unInterruptedAxi4Packets" case_unInterruptedAxi4Packets - ] +tests = + testGroup + "Tests.Axi4.Properties" + [ HU.testCase "case_isPackedAxi4StreamPacket" case_isPackedAxi4StreamPacket + , HU.testCase "case_hasLeadingNullBytes" case_hasLeadingNullBytes + , HU.testCase "case_hasTrailingNullBytes" case_hasTrailingNullBytes + , HU.testCase "case_isSinglePacket" case_isSinglePacket + , HU.testCase "case_isStrictlySparseAxi4StreamPacket" case_isStrictlySparseAxi4StreamPacket + , HU.testCase "case_isUnalignedAxi4StreamPacket" case_isUnalignedAxi4StreamPacket + , HU.testCase "case_unInterruptedAxi4Packets" case_unInterruptedAxi4Packets + ] -- | Apply filters to an Axi4StreamM2S packet byteTypeFilter :: [[AxiByteType] -> Bool] -> [Axi4StreamM2S conf a] -> Bool @@ -33,17 +34,20 @@ byteTypeFilter filters packet = all ($ getPacketByteTypes packet) filters -- | A packet does not contain null bytes between the first and last data or position byte isPackedAxi4StreamPacket :: [AxiByteType] -> Bool isPackedAxi4StreamPacket = - all (== NullByte) . -- There should not be data or position bytes left - dropWhile (/= NullByte) . -- Find first null byte -- Find first null byte - dropWhile (== NullByte) -- Find first data or position byte - --- | A strictly sparse packet contains at least one position byte between the first --- and last data byte + all (== NullByte) + . dropWhile (/= NullByte) -- There should not be data or position bytes left + . dropWhile (== NullByte) -- Find first null byte -- Find first null byte + -- Find first data or position byte + +{- | A strictly sparse packet contains at least one position byte between the first +and last data byte +-} isStrictlySparseAxi4StreamPacket :: [AxiByteType] -> Bool isStrictlySparseAxi4StreamPacket = - elem DataByte . -- There should still be data bytes left - dropWhile (/= PositionByte) . -- Find first position byte -- Find first position byte - dropWhile (/= DataByte) -- Find first data byte + elem DataByte + . dropWhile (/= PositionByte) -- There should still be data bytes left + . dropWhile (/= DataByte) -- Find first position byte -- Find first position byte + -- Find first data byte -- | Continuous packets do not contain null bytes between the first and last data byte isContinuousAxi4StreamPacket :: [AxiByteType] -> Bool @@ -53,41 +57,46 @@ isContinuousAxi4StreamPacket = notElem NullByte isAlignedAxi4StreamPacket :: [AxiByteType] -> Bool isAlignedAxi4StreamPacket = notElem PositionByte --- | Unaligned packets contain position bytes at the beginning and/or end of the packet, --- but not between the first and last data byte. +{- | Unaligned packets contain position bytes at the beginning and/or end of the packet, +but not between the first and last data byte. +-} isUnalignedAxi4StreamPacket :: [AxiByteType] -> Bool isUnalignedAxi4StreamPacket bytes0 | null bytes1 = False | otherwise = - ((== PositionByte) (L.head bytes1) || (== PositionByte) (L.last bytes1)) && - not (isStrictlySparseAxi4StreamPacket bytes1) + ((== PositionByte) (L.head bytes1) || (== PositionByte) (L.last bytes1)) + && not (isStrictlySparseAxi4StreamPacket bytes1) where bytes1 = filter (/= NullByte) bytes0 --- | Leading null bytes are null bytes that appear before the first data or position byte. --- If a packet contains only null bytes, this returns @False@. +{- | Leading null bytes are null bytes that appear before the first data or position byte. +If a packet contains only null bytes, this returns @False@. +-} hasLeadingNullBytes :: [AxiByteType] -> Bool hasLeadingNullBytes [] = False -hasLeadingNullBytes (x:xs) = x == NullByte && any (/= NullByte) xs +hasLeadingNullBytes (x : xs) = x == NullByte && any (/= NullByte) xs --- | Trailing null bytes are null bytes at the end of a packet --- If a packet contains only null bytes, this returns @False@. +{- | Trailing null bytes are null bytes at the end of a packet +If a packet contains only null bytes, this returns @False@. +-} hasTrailingNullBytes :: [AxiByteType] -> Bool hasTrailingNullBytes [] = False hasTrailingNullBytes xs = (L.last xs == NullByte) && any (/= NullByte) xs --- | Check if a list of Axi4StreamM2S transfers form an uninterrupted stream. --- When a packet transmission is started, all elements should be Just until the --- last transfer of the packet is reached. +{- | Check if a list of Axi4StreamM2S transfers form an uninterrupted stream. +When a packet transmission is started, all elements should be Just until the +last transfer of the packet is reached. +-} unInterruptedAxi4Packets :: [Maybe (Axi4StreamM2S conf userType)] -> Bool unInterruptedAxi4Packets xs = case break (maybe False _tlast) (dropWhile isNothing xs) of (payload, l : rest) -> all isJust (payload <> [l]) && unInterruptedAxi4Packets rest (ys, []) -> all isJust ys --- | Check if a list of Axi4StreamM2S transfers form a single packet. --- A list of `Axi4StreamM2S` transfers form a single packet if only the last transfer --- has `_tlast` set. +{- | Check if a list of Axi4StreamM2S transfers form a single packet. +A list of `Axi4StreamM2S` transfers form a single packet if only the last transfer +has `_tlast` set. +-} isSinglePacket :: [Axi4StreamM2S conf userType] -> Bool isSinglePacket axis = case break _tlast axis of (_, [_]) -> True @@ -102,49 +111,79 @@ case_isPackedAxi4StreamPacket = do HU.assertBool "expected packed" $ isPackedAxi4StreamPacket [NullByte, DataByte] HU.assertBool "expected packed" $ isPackedAxi4StreamPacket [DataByte, NullByte] HU.assertBool "expected packed" $ isPackedAxi4StreamPacket [NullByte, NullByte, NullByte] - HU.assertBool "expected unpacked" $ (not . isPackedAxi4StreamPacket) [DataByte, NullByte, DataByte] - HU.assertBool "expected unpacked" $ (not . isPackedAxi4StreamPacket) [NullByte, PositionByte, NullByte, PositionByte] - HU.assertBool "expected unpacked" $ (not . isPackedAxi4StreamPacket) [NullByte, DataByte, NullByte, PositionByte] - HU.assertBool "expected unpacked" $ (not . isPackedAxi4StreamPacket) [DataByte, NullByte, PositionByte, NullByte] + HU.assertBool "expected unpacked" + $ (not . isPackedAxi4StreamPacket) [DataByte, NullByte, DataByte] + HU.assertBool "expected unpacked" + $ (not . isPackedAxi4StreamPacket) [NullByte, PositionByte, NullByte, PositionByte] + HU.assertBool "expected unpacked" + $ (not . isPackedAxi4StreamPacket) [NullByte, DataByte, NullByte, PositionByte] + HU.assertBool "expected unpacked" + $ (not . isPackedAxi4StreamPacket) [DataByte, NullByte, PositionByte, NullByte] case_isStrictlySparseAxi4StreamPacket :: HU.Assertion case_isStrictlySparseAxi4StreamPacket = do HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [] HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [DataByte] - HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte] - HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [DataByte, NullByte] - HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte, NullByte] - HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte, DataByte] - HU.assertBool "expected not sparse" $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte, DataByte, PositionByte] - HU.assertBool "expected sparse" $ isStrictlySparseAxi4StreamPacket [DataByte, PositionByte, DataByte, PositionByte] - HU.assertBool "expected sparse" $ isStrictlySparseAxi4StreamPacket [DataByte, PositionByte, DataByte] - HU.assertBool "expected sparse" $ isStrictlySparseAxi4StreamPacket [DataByte, PositionByte, DataByte, NullByte] - HU.assertBool "expected sparse" $ isStrictlySparseAxi4StreamPacket [PositionByte, DataByte, PositionByte, DataByte] + HU.assertBool "expected not sparse" + $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte] + HU.assertBool "expected not sparse" + $ (not . isStrictlySparseAxi4StreamPacket) [DataByte, NullByte] + HU.assertBool "expected not sparse" + $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte, NullByte] + HU.assertBool "expected not sparse" + $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte, DataByte] + HU.assertBool "expected not sparse" + $ (not . isStrictlySparseAxi4StreamPacket) [PositionByte, DataByte, PositionByte] + HU.assertBool "expected sparse" + $ isStrictlySparseAxi4StreamPacket [DataByte, PositionByte, DataByte, PositionByte] + HU.assertBool "expected sparse" + $ isStrictlySparseAxi4StreamPacket [DataByte, PositionByte, DataByte] + HU.assertBool "expected sparse" + $ isStrictlySparseAxi4StreamPacket [DataByte, PositionByte, DataByte, NullByte] + HU.assertBool "expected sparse" + $ isStrictlySparseAxi4StreamPacket [PositionByte, DataByte, PositionByte, DataByte] case_isUnalignedAxi4StreamPacket :: HU.Assertion case_isUnalignedAxi4StreamPacket = do HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [PositionByte] HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [PositionByte, DataByte] HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [DataByte, PositionByte] - HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [PositionByte, DataByte, PositionByte] - HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [PositionByte, NullByte, DataByte, PositionByte] - HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [NullByte, DataByte, PositionByte] - HU.assertBool "expected unaligned" $ isUnalignedAxi4StreamPacket [DataByte, PositionByte, NullByte] + HU.assertBool "expected unaligned" + $ isUnalignedAxi4StreamPacket [PositionByte, DataByte, PositionByte] + HU.assertBool "expected unaligned" + $ isUnalignedAxi4StreamPacket [PositionByte, NullByte, DataByte, PositionByte] + HU.assertBool "expected unaligned" + $ isUnalignedAxi4StreamPacket [NullByte, DataByte, PositionByte] + HU.assertBool "expected unaligned" + $ isUnalignedAxi4StreamPacket [DataByte, PositionByte, NullByte] HU.assertBool "expected not unaligned" $ not $ isUnalignedAxi4StreamPacket [] HU.assertBool "expected not unaligned" $ not $ isUnalignedAxi4StreamPacket [DataByte] - HU.assertBool "expected not unaligned" $ not $ isUnalignedAxi4StreamPacket [DataByte, PositionByte, DataByte] - HU.assertBool "expected not unaligned" $ not $ isUnalignedAxi4StreamPacket [PositionByte, DataByte, PositionByte, DataByte] - HU.assertBool "expected not unaligned" $ not $ isUnalignedAxi4StreamPacket [DataByte, PositionByte, DataByte, PositionByte] + HU.assertBool "expected not unaligned" + $ not + $ isUnalignedAxi4StreamPacket [DataByte, PositionByte, DataByte] + HU.assertBool "expected not unaligned" + $ not + $ isUnalignedAxi4StreamPacket [PositionByte, DataByte, PositionByte, DataByte] + HU.assertBool "expected not unaligned" + $ not + $ isUnalignedAxi4StreamPacket [DataByte, PositionByte, DataByte, PositionByte] case_unInterruptedAxi4Packets :: HU.Assertion case_unInterruptedAxi4Packets = do HU.assertBool "expected uninterrupted" $ unInterruptedAxi4Packets [Nothing, lastTransfer] - HU.assertBool "expected uninterrupted" $ unInterruptedAxi4Packets [Nothing, lastTransfer, Nothing] - HU.assertBool "expected uninterrupted" $ unInterruptedAxi4Packets [Nothing, payloadTransfer, lastTransfer] - HU.assertBool "expected uninterrupted" $ unInterruptedAxi4Packets [payloadTransfer, payloadTransfer, lastTransfer] - HU.assertBool "expected uninterrupted" $ unInterruptedAxi4Packets [lastTransfer, payloadTransfer, lastTransfer] - HU.assertBool "expected not uninterrupted" $ unInterruptedAxi4Packets [lastTransfer, Nothing, payloadTransfer, lastTransfer] - HU.assertBool "expected not uninterrupted" $ not $ unInterruptedAxi4Packets [Nothing, payloadTransfer, Nothing, lastTransfer] + HU.assertBool "expected uninterrupted" + $ unInterruptedAxi4Packets [Nothing, lastTransfer, Nothing] + HU.assertBool "expected uninterrupted" + $ unInterruptedAxi4Packets [Nothing, payloadTransfer, lastTransfer] + HU.assertBool "expected uninterrupted" + $ unInterruptedAxi4Packets [payloadTransfer, payloadTransfer, lastTransfer] + HU.assertBool "expected uninterrupted" + $ unInterruptedAxi4Packets [lastTransfer, payloadTransfer, lastTransfer] + HU.assertBool "expected not uninterrupted" + $ unInterruptedAxi4Packets [lastTransfer, Nothing, payloadTransfer, lastTransfer] + HU.assertBool "expected not uninterrupted" + $ not + $ unInterruptedAxi4Packets [Nothing, payloadTransfer, Nothing, lastTransfer] where payloadTransfer = Just $ mkDummyM2S (repeat True) False lastTransfer = Just $ mkDummyM2S (repeat True) True @@ -155,8 +194,12 @@ case_isSinglePacket = do HU.assertBool "expected single packet" $ isSinglePacket [payloadTransfer, lastTransfer] HU.assertBool "expected not single packet" $ not $ isSinglePacket [] HU.assertBool "expected not single packet" $ not $ isSinglePacket [payloadTransfer] - HU.assertBool "expected not single packet" $ not $ isSinglePacket [lastTransfer, payloadTransfer] - HU.assertBool "expected not single packet" $ not $ isSinglePacket [lastTransfer, payloadTransfer, lastTransfer] + HU.assertBool "expected not single packet" + $ not + $ isSinglePacket [lastTransfer, payloadTransfer] + HU.assertBool "expected not single packet" + $ not + $ isSinglePacket [lastTransfer, payloadTransfer, lastTransfer] where payloadTransfer = mkDummyM2S (repeat True) False lastTransfer = mkDummyM2S (repeat True) True @@ -166,7 +209,9 @@ case_hasLeadingNullBytes = do HU.assertBool "expected leading null bytes" $ hasLeadingNullBytes [NullByte, DataByte] HU.assertBool "expected not leading null bytes" $ not $ hasLeadingNullBytes [] HU.assertBool "expected not leading null bytes" $ not $ hasLeadingNullBytes [DataByte] - HU.assertBool "expected not leading null bytes" $ not $ hasLeadingNullBytes [DataByte, NullByte] + HU.assertBool "expected not leading null bytes" + $ not + $ hasLeadingNullBytes [DataByte, NullByte] HU.assertBool "expected not leading null bytes" $ not $ hasLeadingNullBytes [NullByte] case_hasTrailingNullBytes :: HU.Assertion @@ -175,15 +220,18 @@ case_hasTrailingNullBytes = do HU.assertBool "expected not trailing null bytes" $ not $ hasTrailingNullBytes [] HU.assertBool "expected not trailing null bytes" $ not $ hasTrailingNullBytes [DataByte] HU.assertBool "expected not trailing null bytes" $ not $ hasTrailingNullBytes [NullByte] - HU.assertBool "expected not trailing null bytes" $ not $ hasTrailingNullBytes [NullByte, DataByte] - -mkDummyM2S :: Vec 4 Bool -> Bool -> Axi4StreamM2S ('Axi4StreamConfig 4 0 0 ) () -mkDummyM2S keep last0 = Axi4StreamM2S - { _tdata = repeat 0 - , _tkeep = keep - , _tstrb = repeat True - , _tlast = last0 - , _tid = 0 - , _tdest = 0 - , _tuser = () - } + HU.assertBool "expected not trailing null bytes" + $ not + $ hasTrailingNullBytes [NullByte, DataByte] + +mkDummyM2S :: Vec 4 Bool -> Bool -> Axi4StreamM2S ('Axi4StreamConfig 4 0 0) () +mkDummyM2S keep last0 = + Axi4StreamM2S + { _tdata = repeat 0 + , _tkeep = keep + , _tstrb = repeat True + , _tlast = last0 + , _tid = 0 + , _tdest = 0 + , _tuser = () + } diff --git a/bittide/tests/Tests/Axi4/Types.hs b/bittide/tests/Tests/Axi4/Types.hs index 8040e67a4..0db04d9d5 100644 --- a/bittide/tests/Tests/Axi4/Types.hs +++ b/bittide/tests/Tests/Axi4/Types.hs @@ -1,18 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} module Tests.Axi4.Types where import Clash.Prelude -import Protocols.Axi4.Stream -import Data.Maybe import Bittide.Extra.Maybe import Clash.Sized.Vector (unsafeFromList) +import Data.Maybe +import Protocols.Axi4.Stream import qualified Data.List as L @@ -46,13 +45,14 @@ getByte True False p = Position p getByte False False _ = Null getByte False True _ = deepErrorX "Reserved byte" --- | Get a list of byte types from an Axi4StreamM2S packet. --- Input must satisfy `isSinglePacket` +{- | Get a list of byte types from an Axi4StreamM2S packet. +Input must satisfy `isSinglePacket` +-} getPacketByteTypes :: [Axi4StreamM2S conf a] -> [AxiByteType] getPacketByteTypes = L.concatMap (toList . fmap getByteType . getTransferBytes) -- | Get the byte type based on a keep and strobe value -getByteType :: AxiByte-> AxiByteType +getByteType :: AxiByte -> AxiByteType getByteType (Data _) = DataByte getByteType (Position _) = PositionByte getByteType Null = NullByte @@ -65,51 +65,55 @@ getKeepStrobe PositionByte = (True, False) -- | Transform a list of Axi Stream operations into a 'Packet'. axiStreamToPackets :: - KnownNat nBytes => + (KnownNat nBytes) => [Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ()] -> [Packet] axiStreamToPackets = L.reverse . snd . L.foldl go ([], []) where go (partialPacket, packets) Axi4StreamM2S{..} | _tlast = ([], L.reverse newPartial : packets) - | otherwise = (newPartial, packets) + | otherwise = (newPartial, packets) where newPartial = L.reverse (catMaybes (toList $ orNothing <$> _tkeep <*> _tdata)) <> partialPacket -- Transform a 'Packet' into a list of Axi Stream operations. packetToAxiStream :: - forall nBytes . + forall nBytes. SNat nBytes -> Packet -> [Maybe (Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ())] packetToAxiStream w@SNat !bs | rest /= [] = Just axis : packetToAxiStream w rest - | otherwise = [Just axis] - where + | otherwise = [Just axis] + where busWidth = natToNum @nBytes (firstWords, rest) = L.splitAt busWidth bs word = L.take busWidth (firstWords <> L.repeat 0) - axis = Axi4StreamM2S - { _tdata = unsafeFromList word - , _tkeep = keeps - , _tstrb = repeat True - , _tlast = null rest - , _tid = 0 - , _tdest = 0 - , _tuser = deepErrorX "" - } - keeps = unsafeFromList $ - L.replicate (L.length bs) True <> L.repeat False + axis = + Axi4StreamM2S + { _tdata = unsafeFromList word + , _tkeep = keeps + , _tstrb = repeat True + , _tlast = null rest + , _tid = 0 + , _tdest = 0 + , _tuser = deepErrorX "" + } + keeps = + unsafeFromList + $ L.replicate (L.length bs) True + <> L.repeat False -- | Separate a list of Axi4Stream operations into a list of Axi4Stream packets. separatePackets :: - forall nBytes . - KnownNat nBytes => + forall nBytes. + (KnownNat nBytes) => [Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ()] -> [ Either - [Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ()] - [Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ()]] + [Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ()] + [Axi4StreamM2S ('Axi4StreamConfig nBytes 0 0) ()] + ] separatePackets [] = [] separatePackets axis = case L.break _tlast axis of - (payload, l:rest) -> Right (payload <> [l]) : separatePackets rest - (remainder, _) -> [Left remainder] + (payload, l : rest) -> Right (payload <> [l]) : separatePackets rest + (remainder, _) -> [Left remainder] diff --git a/bittide/tests/Tests/Calendar.hs b/bittide/tests/Tests/Calendar.hs index 1ce46fa86..dd6d8d0e7 100644 --- a/bittide/tests/Tests/Calendar.hs +++ b/bittide/tests/Tests/Calendar.hs @@ -1,19 +1,16 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - - -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} -module Tests.Calendar(tests, genCalendarConfig, genValidEntry) where +module Tests.Calendar (tests, genCalendarConfig, genValidEntry) where import Clash.Prelude @@ -23,7 +20,7 @@ import Clash.Hedgehog.Sized.Vector import Clash.Sized.Vector (unsafeFromList) import Data.Proxy import Data.String -import Data.Type.Equality ((:~:)(Refl)) +import Data.Type.Equality ((:~:) (Refl)) import Hedgehog import Hedgehog.Gen as Gen import Hedgehog.Range as Range @@ -36,27 +33,37 @@ import Bittide.SharedTypes import Tests.Shared import qualified Clash.Sized.Vector as V +import qualified Clash.Util.Interpolate as I import qualified Data.Set as Set import qualified GHC.TypeNats as TN import qualified Prelude as P -import qualified Clash.Util.Interpolate as I tests :: TestTree -tests = testGroup "Tests.Calendar" - [ testPropertyNamed "Reading the calendar." "readCalendar" readCalendar - , testPropertyNamed "Writing and reading new calendars" "reconfigCalendar" reconfigCalendar - , testPropertyNamed "Reading shadow buffer with wishbone" "readShadowCalendar" readShadowCalendar - , testPropertyNamed "Metacycle signal generation" "metaCycleIndication" metaCycleIndication] - --- | A vector with a minimum size of 1 elements containing Bitvectors of arbitrary size. --- This data type enables us to generate differently sized calendars that satisfy the constraints --- imposed by the calendar component. +tests = + testGroup + "Tests.Calendar" + [ testPropertyNamed "Reading the calendar." "readCalendar" readCalendar + , testPropertyNamed "Writing and reading new calendars" "reconfigCalendar" reconfigCalendar + , testPropertyNamed + "Reading shadow buffer with wishbone" + "readShadowCalendar" + readShadowCalendar + , testPropertyNamed "Metacycle signal generation" "metaCycleIndication" metaCycleIndication + ] + +{- | A vector with a minimum size of 1 elements containing Bitvectors of arbitrary size. +This data type enables us to generate differently sized calendars that satisfy the constraints +imposed by the calendar component. +-} data BVCalendar addrW where BVCalendar :: ( KnownNat addrW - , KnownNat n, 2 <= n - , KnownNat bits, 1 <= bits - , KnownNat validityBits) => + , KnownNat n + , 2 <= n + , KnownNat bits + , 1 <= bits + , KnownNat validityBits + ) => -- | Amount of entries in the BitVector calendar SNat n -> -- | Amount of bits per BitVector in the calendar. @@ -70,19 +77,23 @@ data BVCalendar addrW where instance Show (BVCalendar addrW) where show (BVCalendar _ _ _ bvvec) = show bvvec --- | Generates a configuration for 'Bittide.Calendar.calendar', with as first argument --- the maximum depth of the stored calendar and as second argument a generator for the --- calendar entries. +{- | Generates a configuration for 'Bittide.Calendar.calendar', with as first argument +the maximum depth of the stored calendar and as second argument a generator for the +calendar entries. +-} genCalendarConfig :: - forall nBytes addrW a validityBits . - ( KnownNat nBytes , 1 <= nBytes - , KnownNat addrW, 2 <= addrW + forall nBytes addrW a validityBits. + ( KnownNat nBytes + , 1 <= nBytes + , KnownNat addrW + , 2 <= addrW , KnownNat (BitSize a) , KnownNat validityBits , BitPack a , NFDataX a , Show a - , ShowX a) => + , ShowX a + ) => -- | Maximum amount of entries a calendar based on the returned configuration can hold per calendar. Natural -> -- | Generator for the entries in the shadow calendar and active calendar. @@ -93,19 +104,23 @@ genCalendarConfig ms elemGen = do dB <- Gen.enum 1 ms case (TN.someNatVal (ms - 2), TN.someNatVal dA, TN.someNatVal dB) of ( SomeNat (addSNat d2 . snatProxy -> maxSize) - ,SomeNat (snatProxy -> depthA) - ,SomeNat (snatProxy -> depthB)) -> do + , SomeNat (snatProxy -> depthA) + , SomeNat (snatProxy -> depthB) + ) -> do let - regAddrBits = SNat - @( NatRequiredBits (Regs (ValidEntry a validityBits) (nBytes * 8) + ExtraRegs)) + regAddrBits = + SNat + @(NatRequiredBits (Regs (ValidEntry a validityBits) (nBytes * 8) + ExtraRegs)) bsCalEntry = SNat @(BitSize a) - case - ( isInBounds d1 depthA maxSize - , isInBounds d1 depthB maxSize - , compareSNat regAddrBits (SNat @addrW) - , compareSNat d1 bsCalEntry) of - (InBounds, InBounds, SNatLE, SNatLE)-> go maxSize depthA depthB - (a, b, c, d) -> error [I.i| + case ( isInBounds d1 depthA maxSize + , isInBounds d1 depthB maxSize + , compareSNat regAddrBits (SNat @addrW) + , compareSNat d1 bsCalEntry + ) of + (InBounds, InBounds, SNatLE, SNatLE) -> go maxSize depthA depthB + (a, b, c, d) -> + error + [I.i| genCalendarConfig: calEntry constraints not satisfied: a: #{a} @@ -116,60 +131,67 @@ genCalendarConfig ms elemGen = do ... |] where - go :: - forall maxDepth depthA depthB . - ( LessThan depthA maxDepth - , LessThan depthB maxDepth - , 1 <= depthA - , 1 <= depthB - , 2 <= maxDepth - , NatFitsInBits (Regs (ValidEntry a validityBits) (nBytes * 8) + ExtraRegs) addrW) => - SNat maxDepth -> - SNat depthA -> - SNat depthB -> - Gen (CalendarConfig nBytes addrW a) - go dMax SNat SNat = do - calActive <- genVec @_ @depthA elemGen - calShadow <- genVec @_ @depthB elemGen - return $ CalendarConfig dMax calActive calShadow + go :: + forall maxDepth depthA depthB. + ( LessThan depthA maxDepth + , LessThan depthB maxDepth + , 1 <= depthA + , 1 <= depthB + , 2 <= maxDepth + , NatFitsInBits (Regs (ValidEntry a validityBits) (nBytes * 8) + ExtraRegs) addrW + ) => + SNat maxDepth -> + SNat depthA -> + SNat depthB -> + Gen (CalendarConfig nBytes addrW a) + go dMax SNat SNat = do + calActive <- genVec @_ @depthA elemGen + calShadow <- genVec @_ @depthB elemGen + return $ CalendarConfig dMax calActive calShadow genValidEntry :: SNat repetitionBits -> Gen a -> Gen (ValidEntry a repetitionBits) -genValidEntry SNat genA = (\veEntry veRepeat -> ValidEntry{veEntry, veRepeat}) - <$> genA - <*> genUnsigned Range.linearBounded +genValidEntry SNat genA = + (\veEntry veRepeat -> ValidEntry{veEntry, veRepeat}) + <$> genA + <*> genUnsigned Range.linearBounded -- | Generates a 'BVCalendar' of a certain size and width for the stored BitVectors. genBVCalendar :: Integer -> Integer -> Integer -> Gen (BVCalendar 32) genBVCalendar calSize bitWidth validityBits = do let - calNat = TN.someNatVal (fromIntegral $ calSize - 2) - bitNat = TN.someNatVal (fromIntegral bitWidth) - valNat = TN.someNatVal (fromIntegral validityBits) + calNat = TN.someNatVal (fromIntegral $ calSize - 2) + bitNat = TN.someNatVal (fromIntegral bitWidth) + valNat = TN.someNatVal (fromIntegral validityBits) case (calNat, bitNat, valNat) of (SomeNat size, SomeNat bits, SomeNat validity) -> go (addSNat d2 $ snatProxy size) (snatProxy bits) (snatProxy validity) where go :: - forall calSize bitWidth validityBits . + forall calSize bitWidth validityBits. (KnownNat calSize, 2 <= calSize, KnownNat bitWidth) => SNat calSize -> - SNat bitWidth-> + SNat bitWidth -> SNat validityBits -> Gen (BVCalendar 32) go s b v@SNat = do let calNatBits = clogBaseSNat d2 s - case - ( compareSNat calNatBits d32 - , compareSNat d1 calNatBits - , compareSNat d1 b) of + case ( compareSNat calNatBits d32 + , compareSNat d1 calNatBits + , compareSNat d1 b + ) of (SNatLE, SNatLE, SNatLE) -> do - cal <- Gen.list (Range.singleton $ fromIntegral calSize) $ - genValidEntry (SNat @validityBits) - (genDefinedBitVector @bitWidth) + cal <- + Gen.list (Range.singleton $ fromIntegral calSize) + $ genValidEntry + (SNat @validityBits) + (genDefinedBitVector @bitWidth) return (BVCalendar s b v $ unsafeFromList cal) - _ -> error $ - "genIntCalendar: Constraints not satisfied: 1 <= " <> show calNatBits <> " <= 32." + _ -> + error + $ "genIntCalendar: Constraints not satisfied: 1 <= " + <> show calNatBits + <> " <= 32." -- | This test checks if we can read the initialized calendars. readCalendar :: Property @@ -184,8 +206,17 @@ readCalendar = property $ do -- 1 to compensate for reset, length for 1 cycle per element, sum of snds for -- additional validity delays. simLength = 1 + length cal + sum (fmap (fromIntegral . veRepeat) cal) - topEntity = (\(a,_,_) -> a) $ withClockResetEnable clockGen resetGen enableGen - calendarWbSpecVal calSize' cal cal $ pure (emptyWishboneM2S @32 @(BitVector 32)) + topEntity = + (\(a, _, _) -> a) + $ withClockResetEnable + clockGen + resetGen + enableGen + calendarWbSpecVal + calSize' + cal + cal + $ pure (emptyWishboneM2S @32 @(BitVector 32)) simOut = sampleN @System (fromIntegral simLength) topEntity expected = toList $ fmap veEntry cal footnote . fromString $ "simOut: " <> show simOut @@ -193,8 +224,9 @@ readCalendar = property $ do Set.fromList simOut === Set.fromList expected --- | This test checks if we can write to the shadowbuffer and read back the written --- elements later. +{- | This test checks if we can write to the shadowbuffer and read back the written +elements later. +-} reconfigCalendar :: Property reconfigCalendar = property $ do calSize <- forAll $ Gen.int $ Range.constant 2 32 @@ -203,22 +235,33 @@ reconfigCalendar = property $ do bvCal <- forAll $ genBVCalendar (fromIntegral calSize) bitWidth validityBits case bvCal of BVCalendar calSize' _ (SNat :: SNat validityBits) cal -> do - newEntries <- forAll . Gen.list (Range.singleton calSize) $ - genValidEntry (SNat @validityBits) genDefinedBitVector + newEntries <- + forAll + . Gen.list (Range.singleton calSize) + $ genValidEntry (SNat @validityBits) genDefinedBitVector let (entries0, delays0) = unzip $ fmap (\e -> (veEntry e, veRepeat e)) cal (entries1, delays1) = P.unzip $ fmap (\e -> (veEntry e, veRepeat e)) newEntries cal0Duration = calSize + sum (fmap fromIntegral delays0) cal1Duration = calSize + sum (fmap fromIntegral delays1) - writeOps = P.zip (cycle [0.. indexOf calSize']) newEntries + writeOps = P.zip (cycle [0 .. indexOf calSize']) newEntries swapCall = let a = (bitWidth + validityBits) `divRU` 32 + 3 in wbWriteOp (a, 0) wbWrites = wbNothingM2S @4 @32 : P.concatMap writeWithWishbone writeOps <> [swapCall] -- Arming has one cycle delay, writeDuration = 1 + P.length wbWrites -- It may take multiple metacycles to write the new calendar. simLength = cal0Duration * (writeDuration `divRU` cal0Duration) + cal1Duration - topEntity writePort = (\(a,_,_) -> a) $ withClockResetEnable clockGen - resetGen enableGen calendar calSize' cal cal writePort + topEntity writePort = + (\(a, _, _) -> a) + $ withClockResetEnable + clockGen + resetGen + enableGen + calendar + calSize' + cal + cal + writePort topEntityInput = P.take simLength $ wbWrites <> P.repeat wbNothingM2S simOut = simulateN @System simLength topEntity topEntityInput expected = P.take simLength $ toList entries0 <> entries1 @@ -228,8 +271,9 @@ reconfigCalendar = property $ do footnote . fromString $ "Write operations: " <> show writeOps Set.fromList simOut === Set.fromList expected --- | This test checks if we can write to the shadowbuffer and read back the written --- elements later. +{- | This test checks if we can write to the shadowbuffer and read back the written +elements later. +-} readShadowCalendar :: Property readShadowCalendar = property $ do calSize <- forAll $ Gen.enum 2 32 @@ -239,27 +283,36 @@ readShadowCalendar = property $ do calS <- forAll $ genBVCalendar calSize bitWidth validityBits case (calA, calS) of (BVCalendar snatA bwA valA calA', BVCalendar snatS bwS valS calS') -> - case - ( sameNat (asProxy snatA) (asProxy snatS) - , sameNat (asProxy bwA) (asProxy bwS) - , sameNat (asProxy valA) (asProxy valS)) of - (Just Refl, Just Refl, Just Refl) -> do - let - entryRegs = snatToInteger $ requiredRegs (bwS `addSNat` valS) d32 - readAddresses = fmap fromIntegral [0.. indexOf snatS] - simLength = P.length wbReads + 1 - wbReads = P.concatMap (\ i -> wbReadEntry @4 @32 i entryRegs) readAddresses - topEntity writePort = (\(_,_,wb) -> wb) $ - withClockResetEnable clockGen resetGen enableGen - calendar (addSNat d2 snatS) calA' calS' writePort - topEntityInput = P.take simLength $ wbReads <> P.repeat wbNothingM2S - simOut = simulateN @System simLength topEntity topEntityInput - wbOutEntries = directedWbDecoding topEntityInput simOut - wbOutEntries === toList calS' - _ -> error "readShadowCalendar: Calendar sizes or bitwidths do not match." - --- | This test checks if the metacycle signal (which indicates that the last entry of the --- active calendar is present at the output), is correctly being generated. + case ( sameNat (asProxy snatA) (asProxy snatS) + , sameNat (asProxy bwA) (asProxy bwS) + , sameNat (asProxy valA) (asProxy valS) + ) of + (Just Refl, Just Refl, Just Refl) -> do + let + entryRegs = snatToInteger $ requiredRegs (bwS `addSNat` valS) d32 + readAddresses = fmap fromIntegral [0 .. indexOf snatS] + simLength = P.length wbReads + 1 + wbReads = P.concatMap (\i -> wbReadEntry @4 @32 i entryRegs) readAddresses + topEntity writePort = + (\(_, _, wb) -> wb) + $ withClockResetEnable + clockGen + resetGen + enableGen + calendar + (addSNat d2 snatS) + calA' + calS' + writePort + topEntityInput = P.take simLength $ wbReads <> P.repeat wbNothingM2S + simOut = simulateN @System simLength topEntity topEntityInput + wbOutEntries = directedWbDecoding topEntityInput simOut + wbOutEntries === toList calS' + _ -> error "readShadowCalendar: Calendar sizes or bitwidths do not match." + +{- | This test checks if the metacycle signal (which indicates that the last entry of the +active calendar is present at the output), is correctly being generated. +-} metaCycleIndication :: Property metaCycleIndication = property $ do calSize <- forAll $ Gen.enum 3 4 @@ -270,8 +323,10 @@ metaCycleIndication = property $ do case bvCal of BVCalendar (calSize' :: SNat calDepth) _ _ cal -> do let - genDepth = fromIntegral <$> genIndex @_ @calDepth - (Range.constant 2 (fromIntegral $ pred calSize)) + genDepth = + fromIntegral + <$> genIndex @_ @calDepth + (Range.constant 2 (fromIntegral $ pred calSize)) newDepths <- forAll $ Gen.list (Range.singleton (metaCycles - 1)) genDepth let reqRegs = (bitWidth + validityBits) `divRU` 32 @@ -284,29 +339,41 @@ metaCycleIndication = property $ do let swapCall = wbWriteOp @4 @32 (swapAddr, 0) wbWrites = P.drop 3 $ P.concatMap writeAndSwitch (P.zip allDepths allDurations) - writeAndSwitch (dep, dur) = P.take (succ dur) $ - [wbWriteOp (newDepthAddr, fromIntegral dep),swapCall] <> P.repeat wbNothingM2S - topEntity writePort = (\(_,m,_) -> m) $ withClockResetEnable - clockGen resetGen enableGen calendarWbSpecVal calSize' cal cal writePort + writeAndSwitch (dep, dur) = + P.take (succ dur) + $ [wbWriteOp (newDepthAddr, fromIntegral dep), swapCall] + <> P.repeat wbNothingM2S + topEntity writePort = + (\(_, m, _) -> m) + $ withClockResetEnable + clockGen + resetGen + enableGen + calendarWbSpecVal + calSize' + cal + cal + writePort topEntityInput = wbWrites <> P.repeat wbNothingM2S simOut = simulateN @System simLength topEntity topEntityInput - expectedOut = P.take simLength $ - P.concatMap (\ (fromIntegral -> n) -> P.replicate n False <> [True]) - (repeatLast allDurations) + expectedOut = + P.take simLength + $ P.concatMap + (\(fromIntegral -> n) -> P.replicate n False <> [True]) + (repeatLast allDurations) footnote . fromString $ "Simulation: " <> show simOut footnote . fromString $ "Expected: " <> show expectedOut footnote . fromString $ "All Depths: " <> show allDurations footnote . fromString $ "wishbone in: " <> show (P.take simLength wbWrites) simOut === expectedOut - repeatLast :: [a] -> [a] repeatLast [] = [] repeatLast [l] = P.repeat l -repeatLast (l:ist) = l : repeatLast ist +repeatLast (l : ist) = l : repeatLast ist -- | Gets the index of element (n+1) -indexOf :: forall n . (KnownNat n, 1 <= n) => SNat n -> Index n +indexOf :: forall n. (KnownNat n, 1 <= n) => SNat n -> Index n indexOf = leToPlus @1 @n (fromSNat . predSNat) -- | Interpret SNat as Proxy for use by 'sameNat'. @@ -314,11 +381,11 @@ asProxy :: SNat n -> Proxy n asProxy SNat = Proxy -- | Get the amount of required registers for storing a BitVector bits in registers of regSize. -requiredRegs - :: (1 <= regSize) - => SNat bits - -> SNat regSize - -> SNat (Regs (BitVector bits) regSize) +requiredRegs :: + (1 <= regSize) => + SNat bits -> + SNat regSize -> + SNat (Regs (BitVector bits) regSize) requiredRegs SNat SNat = SNat -- | idle 'Protocols.Wishbone.WishboneM2S' bus. @@ -328,15 +395,16 @@ wbNothingM2S :: WishboneM2S addrW nBytes (Bytes nBytes) wbNothingM2S = (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = 0, - writeData = 0, - busSelect = 0 + { addr = 0 + , writeData = 0 + , busSelect = 0 } --- | Write an entry to some address in 'Bittide.Calendar.calendar', this may require --- multiple write operations. +{- | Write an entry to some address in 'Bittide.Calendar.calendar', this may require +multiple write operations. +-} writeWithWishbone :: - forall nBytes addrW n entry . + forall nBytes addrW n entry. (KnownNat nBytes, 1 <= nBytes, KnownNat addrW, KnownNat n, Paddable entry) => (Index n, entry) -> [WishboneM2S addrW nBytes (Bytes nBytes)] @@ -344,127 +412,144 @@ writeWithWishbone (a, entry) = case getRegsLe entry of RegisterBank vec -> toList $ fmap wbWriteOp $ zip indicesI (vec :< fromIntegral a) --- | Use both the wishbone M2S bus and S2M bus to decode the S2M bus operations into the --- expected type a. -directedWbDecoding - :: forall nBytes addrW a - . (KnownNat nBytes - , 1 <= nBytes - , KnownNat addrW - , Paddable a) - => [WishboneM2S addrW nBytes (Bytes nBytes)] - -> [WishboneS2M (Bytes nBytes)] - -> [a] -directedWbDecoding (wbM2S:m2sRest) (_:s2mRest) = out +{- | Use both the wishbone M2S bus and S2M bus to decode the S2M bus operations into the +expected type a. +-} +directedWbDecoding :: + forall nBytes addrW a. + ( KnownNat nBytes + , 1 <= nBytes + , KnownNat addrW + , Paddable a + ) => + [WishboneM2S addrW nBytes (Bytes nBytes)] -> + [WishboneS2M (Bytes nBytes)] -> + [a] +directedWbDecoding (wbM2S : m2sRest) (_ : s2mRest) = out where active = strobe wbM2S && busCycle wbM2S foundBeginning = writeEnable wbM2S && active expectReadData :: ( WishboneM2S addrW nBytes (Bytes nBytes) - , WishboneS2M (Bytes nBytes) ) -> + , WishboneS2M (Bytes nBytes) + ) -> Bool - expectReadData (WishboneM2S{strobe, busCycle, writeEnable},_) = + expectReadData (WishboneM2S{strobe, busCycle, writeEnable}, _) = strobe && busCycle && not writeEnable entryList = fmap (readData . snd) - $ takeWhile expectReadData . filterNoOps - $ P.zip m2sRest s2mRest + $ takeWhile expectReadData + . filterNoOps + $ P.zip m2sRest s2mRest - filterNoOps l = [(m2s,s2m)| (m2s,s2m) <- l, m2s /= wbNothingM2S] + filterNoOps l = [(m2s, s2m) | (m2s, s2m) <- l, m2s /= wbNothingM2S] entry = case V.fromList $ P.reverse entryList of Just (vec :: Vec (Regs a (nBytes * 8)) (Bytes nBytes)) -> getDataLe (RegisterBank vec) - Nothing -> - error $ - "directedWbDecoding: list to vector conversion failed: " - <> show entryList <> "from " <> show (wbM2S:m2sRest) + Nothing -> + error + $ "directedWbDecoding: list to vector conversion failed: " + <> show entryList + <> "from " + <> show (wbM2S : m2sRest) consumedReads = P.length entryList remainingM2S = P.drop consumedReads m2sRest remainingS2M = P.drop consumedReads s2mRest - out | foundBeginning = entry : directedWbDecoding remainingM2S remainingS2M - | otherwise = directedWbDecoding m2sRest s2mRest - + out + | foundBeginning = entry : directedWbDecoding remainingM2S remainingS2M + | otherwise = directedWbDecoding m2sRest s2mRest directedWbDecoding _ _ = [] --- | Returns the wishbone M2S bus inputs required to read a calendar entry from --- 'Bittide.Calendar.calendar'. It first writes the entry's address to the read register, --- then adds the read operations. +{- | Returns the wishbone M2S bus inputs required to read a calendar entry from +'Bittide.Calendar.calendar'. It first writes the entry's address to the read register, +then adds the read operations. +-} wbReadEntry :: - forall nBytes addrW i . + forall nBytes addrW i. (KnownNat nBytes, KnownNat addrW, Integral i) => i -> i -> [WishboneM2S addrW nBytes (Bytes nBytes)] wbReadEntry i dataRegs = addrWrite : wbNothingM2S : dataReads where - addrWrite = (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = 4 * fromIntegral (dataRegs + 1) - , writeData = fromIntegral i - , busSelect = maxBound - , busCycle = True - , strobe = True - , writeEnable = True} - dataReads = readReg <$> P.reverse [0..(dataRegs-1)] - readReg n = (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = 4 * fromIntegral n - , writeData = 0 - , busSelect = maxBound - , busCycle = True - , strobe = True - , writeEnable = False - } - --- | Transform a target address i and a bitvector to a Wishbone write operation that writes --- the bitvector to address i. + addrWrite = + (emptyWishboneM2S @addrW @(Bytes nBytes)) + { addr = 4 * fromIntegral (dataRegs + 1) + , writeData = fromIntegral i + , busSelect = maxBound + , busCycle = True + , strobe = True + , writeEnable = True + } + dataReads = readReg <$> P.reverse [0 .. (dataRegs - 1)] + readReg n = + (emptyWishboneM2S @addrW @(Bytes nBytes)) + { addr = 4 * fromIntegral n + , writeData = 0 + , busSelect = maxBound + , busCycle = True + , strobe = True + , writeEnable = False + } + +{- | Transform a target address i and a bitvector to a Wishbone write operation that writes +the bitvector to address i. +-} wbWriteOp :: - forall nBytes addrW i . + forall nBytes addrW i. (KnownNat nBytes, KnownNat addrW, Integral i) => (i, Bytes nBytes) -> WishboneM2S addrW nBytes (Bytes nBytes) wbWriteOp (i, bv) = (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = 4 * fromIntegral i - , writeData = bv - , busSelect = maxBound - , busCycle = True - , strobe = True - , writeEnable = True} + { addr = 4 * fromIntegral i + , writeData = bv + , busSelect = maxBound + , busCycle = True + , strobe = True + , writeEnable = True + } -- | Version of 'Bittide.Calendar.calendar' which performs Wishbone spec validation calendarWbSpecVal :: - forall dom nBytes addrW maxCalDepth a validityBits bootstrapSizeA bootstrapSizeB . + forall dom nBytes addrW maxCalDepth a validityBits bootstrapSizeA bootstrapSizeB. ( HiddenClockResetEnable dom - , KnownNat addrW, 2 <= addrW - , KnownNat bootstrapSizeA, 1 <= bootstrapSizeA - , KnownNat bootstrapSizeB, 1 <= bootstrapSizeB - , KnownNat nBytes, 1 <= nBytes + , KnownNat addrW + , 2 <= addrW + , KnownNat bootstrapSizeA + , 1 <= bootstrapSizeA + , KnownNat bootstrapSizeB + , 1 <= bootstrapSizeB + , KnownNat nBytes + , 1 <= nBytes , KnownNat validityBits , 2 <= maxCalDepth , LessThan bootstrapSizeA maxCalDepth , LessThan bootstrapSizeB maxCalDepth , Paddable a , ShowX a - , Show a) => + , Show a + ) => + -- | The maximum amount of entries that can be stored in the individual calendars. SNat maxCalDepth -> - -- ^ The maximum amount of entries that can be stored in the individual calendars. + -- | Bootstrap calendar for the active buffer. Calendar bootstrapSizeA a validityBits -> - -- ^ Bootstrap calendar for the active buffer. + -- | Bootstrap calendar for the shadow buffer. Calendar bootstrapSizeB a validityBits -> - -- ^ Bootstrap calendar for the shadow buffer. + -- | Incoming wishbone interface Signal dom (WishboneM2S addrW nBytes (Bytes nBytes)) -> - -- ^ Incoming wishbone interface + -- | Currently active entry, Metacycle indicator and outgoing wishbone interface. (Signal dom a, Signal dom Bool, Signal dom (WishboneS2M (Bytes nBytes))) - -- ^ Currently active entry, Metacycle indicator and outgoing wishbone interface. calendarWbSpecVal mDepth bootstrapActive bootstrapShadow m2s0 = (active, metaIndicator, s2m1) - where - (active, metaIndicator, s2m0) = - calendar @dom @nBytes @addrW - mDepth - bootstrapActive - bootstrapShadow - m2s1 - (m2s1, s2m1) = validateWb m2s0 s2m0 + where + (active, metaIndicator, s2m0) = + calendar @dom @nBytes @addrW + mDepth + bootstrapActive + bootstrapShadow + m2s1 + (m2s1, s2m1) = validateWb m2s0 s2m0 diff --git a/bittide/tests/Tests/ClockControl/Si539xSpi.hs b/bittide/tests/Tests/ClockControl/Si539xSpi.hs index 2a819ba70..cf6a7417c 100644 --- a/bittide/tests/Tests/ClockControl/Si539xSpi.hs +++ b/bittide/tests/Tests/ClockControl/Si539xSpi.hs @@ -1,49 +1,57 @@ +{-# LANGUAGE NumericUnderscores #-} -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE NumericUnderscores #-} module Tests.ClockControl.Si539xSpi where -import Clash.Prelude -import Clash.Signal.Internal(Signal((:-))) import Clash.Cores.SPI +import Clash.Prelude +import Clash.Signal.Internal (Signal ((:-))) -import Bittide.ClockControl.Si539xSpi import Bittide.ClockControl.Si5391A +import Bittide.ClockControl.Si539xSpi import Bittide.SharedTypes +import qualified Data.Map as Map import Test.Tasty import Test.Tasty.HUnit -import qualified Data.Map as Map createDomain vXilinxSystem{vPeriod = hzToPeriod 1e6, vName = "Basic1"} tests :: TestTree -tests = testGroup "Tests.ClockControl.Si539xSpi" - [ testCase "Configuration succeeds" configureSucceeds] - +tests = + testGroup + "Tests.ClockControl.Si539xSpi" + [testCase "Configuration succeeds" configureSucceeds] topEntity :: Signal Basic1 (Bool, Bool) topEntity = bundle (masterBusy, configState .==. pure Finished) - where - (_, masterBusy, configState, (sclk, mosi,ss)) = - withClockResetEnable clockGen resetGen enableGen $ - si539xSpi testConfigA (SNat @50000) (pure Nothing) miso + where + (_, masterBusy, configState, (sclk, mosi, ss)) = + withClockResetEnable clockGen resetGen enableGen + $ si539xSpi testConfigA (SNat @50000) (pure Nothing) miso miso = si5391Mock sclk mosi ss - -si5391Mock :: forall dom . KnownDomain dom => Signal dom Bool -> Signal dom Bit -> Signal dom Bool -> Signal dom Bit +si5391Mock :: + forall dom. + (KnownDomain dom) => + Signal dom Bool -> + Signal dom Bit -> + Signal dom Bool -> + Signal dom Bit si5391Mock sck mosi ss = readFromBiSignal miso where slaveOut :: Signal dom (Maybe (Bytes 2)) (veryUnsafeToBiSignalIn -> miso, _, slaveOut) = - withClockResetEnable clockGen resetGen enableGen $ - spiSlaveLatticeSBIO SPIMode0 False sck mosi miso ss slaveIn + withClockResetEnable clockGen resetGen enableGen + $ spiSlaveLatticeSBIO SPIMode0 False sck mosi miso ss slaveIn - slaveIn = si5391Model (deepErrorX "", deepErrorX "", Map.fromList [(0x00FE, 0xF), (0x00C0, 0x00)]) slaveOut + slaveIn = + si5391Model + (deepErrorX "", deepErrorX "", Map.fromList [(0x00FE, 0xF), (0x00C0, 0x00)]) + slaveOut si5391Model :: (Page, Address, Map.Map (Bytes 2) Byte) -> @@ -51,11 +59,11 @@ si5391Mock sck mosi ss = readFromBiSignal miso Signal dom (Bytes 2) si5391Model oldState@(page, addr, regs) (maybeInput :- inputs) = case maybeInput of - Nothing -> output :- si5391Model oldState inputs + Nothing -> output :- si5391Model oldState inputs Just input -> output :- si5391Model newState inputs where (command, byte) = split input - newState =case (shiftR command 5, addr) of + newState = case (shiftR command 5, addr) of (0, _) -> (page, byte, regs) (2, 1) -> (byte, addr, regs) (2, _) -> (page, addr, Map.insert key byte regs) diff --git a/bittide/tests/Tests/Counter.hs b/bittide/tests/Tests/Counter.hs index c8f7e0070..7aa2e1b52 100644 --- a/bittide/tests/Tests/Counter.hs +++ b/bittide/tests/Tests/Counter.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -18,21 +17,21 @@ import Test.Tasty.TH import Bittide.Counter (domainDiffCounter) -createDomain vXilinxSystem{vName="D10", vPeriod=hzToPeriod 100e6} -createDomain vXilinxSystem{vName="D17", vPeriod=hzToPeriod 170e6} -createDomain vXilinxSystem{vName="D20", vPeriod=hzToPeriod 200e6} +createDomain vXilinxSystem{vName = "D10", vPeriod = hzToPeriod 100e6} +createDomain vXilinxSystem{vName = "D17", vPeriod = hzToPeriod 170e6} +createDomain vXilinxSystem{vName = "D20", vPeriod = hzToPeriod 200e6} -noRst :: KnownDomain dom => Reset dom +noRst :: (KnownDomain dom) => Reset dom noRst = unsafeFromActiveHigh (pure False) -rst :: KnownDomain dom => Reset dom +rst :: (KnownDomain dom) => Reset dom rst = unsafeFromActiveHigh (pure True) -rstN :: KnownDomain dom => Int -> Reset dom +rstN :: (KnownDomain dom) => Int -> Reset dom rstN n = unsafeFromActiveHigh (fromList (P.replicate n True <> P.repeat False)) top :: - forall src dst . + forall src dst. ( KnownDomain src , KnownDomain dst ) => @@ -55,17 +54,18 @@ case_zeroDstRst = sampleN 1000 (top @D10 @D17 noRst rst) @?= P.replicate 1000 0 -- | No matter when we release the destination reset, we should zeros followed by counting case_glitchless :: Assertion -case_glitchless = -- - forM_ [0..512] $ \n -> do +case_glitchless = + -- + forM_ [0 .. 512] $ \n -> do let sampled = sampleN 1000 (dut (rstN n)) - sampledNonZero = P.dropWhile (==0) sampled + sampledNonZero = P.dropWhile (== 0) sampled len = P.length sampledNonZero assertBool (">1 @ " <> show n) (len > 1) assertEqual ("exp @ " <> show n) sampledNonZero (P.take len expected) where dut = top @D10 @D20 noRst - expected = P.concat [[n, n] | n <- [1..]] + expected = P.concat [[n, n] | n <- [1 ..]] tests :: TestTree tests = $(testGroupGenerator) diff --git a/bittide/tests/Tests/DoubleBufferedRam.hs b/bittide/tests/Tests/DoubleBufferedRam.hs index 893c84c4a..fb850a3ce 100644 --- a/bittide/tests/Tests/DoubleBufferedRam.hs +++ b/bittide/tests/Tests/DoubleBufferedRam.hs @@ -1,17 +1,16 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} -module Tests.DoubleBufferedRam(tests) where + +module Tests.DoubleBufferedRam (tests) where import Clash.Prelude @@ -22,7 +21,7 @@ import Data.Constraint.Nat.Extra import Data.Maybe import Data.Proxy import Data.String -import Data.Type.Equality (type (:~:)(Refl)) +import Data.Type.Equality (type (:~:) (Refl)) import Hedgehog import Hedgehog.Range as Range import Numeric (showHex) @@ -45,40 +44,74 @@ import qualified Hedgehog.Gen as Gen hiding (resize) import qualified Prelude as P tests :: TestTree -tests = testGroup "Tests.DoubleBufferedRam" - [ testPropertyNamed "Reading the buffer." - "readDoubleBufferedRam" readDoubleBufferedRam - , testPropertyNamed "Writing and reading back buffers." - "readWriteDoubleBufferedRam" readWriteDoubleBufferedRam - , testPropertyNamed "Byte addressable blockRam matches behavioral model." - "readWriteByteAddressableBlockram" readWriteByteAddressableBlockram - , testPropertyNamed "Byte addressable blockRam with always high byteEnables behaves like blockRam" - "byteAddressableBlockRamAsBlockRam" byteAddressableBlockRamAsBlockRam - , testPropertyNamed "Byte addressable double buffered blockRam matches behavioral model." - "doubleBufferedRamByteAddressable0" doubleBufferedRamByteAddressable0 - , testPropertyNamed "Byte addressable double buffered blockRam with always high byteEnables behaves like 'doubleBufferedRam'" - "doubleBufferedRamByteAddressable1" doubleBufferedRamByteAddressable1 - , testPropertyNamed "Byte addressable register can be written to and read from with byte enables." - "readWriteRegisterByteAddressable" readWriteRegisterByteAddressable - , testPropertyNamed "registerWb function as a normal register." - "registerWbSigToSig" registerWbSigToSig - , testPropertyNamed "registerWb can be written to with wishbone." - "registerWbWbToSig" registerWbWbToSig - , testPropertyNamed "registerWb can be read from with wishbone." - "registerWbSigToWb" registerWbSigToWb - , testPropertyNamed "registerWb write conflict resolution matches set priorities" - "registerWbWriteCollisions" registerWbWriteCollisions - , testPropertyNamed "Simulate the contentGenerator for an arbitrary vector." - "testContentGen" testContentGen - , testPropertyNamed "Test wishboneStorage spec compliance" - "wbStorageSpecCompliance" wbStorageSpecCompliance - , testPropertyNamed "Test whether wbStorage acts the same its Behavioral model" - "wbStorageBehavior" wbStorageBehavior - , testPropertyNamed "Test whether wbStorage reports errors at out-of-bounds accesses" - "wbStorageRangeErrors" wbStorageRangeErrors - , testPropertyNamed "Test whether wbStorage acts the same its Behavioral model (clash-protocols)" - "wbStorageProtocolsModel" wbStorageProtocolsModel - ] +tests = + testGroup + "Tests.DoubleBufferedRam" + [ testPropertyNamed + "Reading the buffer." + "readDoubleBufferedRam" + readDoubleBufferedRam + , testPropertyNamed + "Writing and reading back buffers." + "readWriteDoubleBufferedRam" + readWriteDoubleBufferedRam + , testPropertyNamed + "Byte addressable blockRam matches behavioral model." + "readWriteByteAddressableBlockram" + readWriteByteAddressableBlockram + , testPropertyNamed + "Byte addressable blockRam with always high byteEnables behaves like blockRam" + "byteAddressableBlockRamAsBlockRam" + byteAddressableBlockRamAsBlockRam + , testPropertyNamed + "Byte addressable double buffered blockRam matches behavioral model." + "doubleBufferedRamByteAddressable0" + doubleBufferedRamByteAddressable0 + , testPropertyNamed + "Byte addressable double buffered blockRam with always high byteEnables behaves like 'doubleBufferedRam'" + "doubleBufferedRamByteAddressable1" + doubleBufferedRamByteAddressable1 + , testPropertyNamed + "Byte addressable register can be written to and read from with byte enables." + "readWriteRegisterByteAddressable" + readWriteRegisterByteAddressable + , testPropertyNamed + "registerWb function as a normal register." + "registerWbSigToSig" + registerWbSigToSig + , testPropertyNamed + "registerWb can be written to with wishbone." + "registerWbWbToSig" + registerWbWbToSig + , testPropertyNamed + "registerWb can be read from with wishbone." + "registerWbSigToWb" + registerWbSigToWb + , testPropertyNamed + "registerWb write conflict resolution matches set priorities" + "registerWbWriteCollisions" + registerWbWriteCollisions + , testPropertyNamed + "Simulate the contentGenerator for an arbitrary vector." + "testContentGen" + testContentGen + , testPropertyNamed + "Test wishboneStorage spec compliance" + "wbStorageSpecCompliance" + wbStorageSpecCompliance + , testPropertyNamed + "Test whether wbStorage acts the same its Behavioral model" + "wbStorageBehavior" + wbStorageBehavior + , testPropertyNamed + "Test whether wbStorage reports errors at out-of-bounds accesses" + "wbStorageRangeErrors" + wbStorageRangeErrors + , testPropertyNamed + "Test whether wbStorage acts the same its Behavioral model (clash-protocols)" + "wbStorageProtocolsModel" + wbStorageProtocolsModel + ] genRamContents :: (MonadGen m, Integral i) => i -> m a -> m (SomeVec 1 a) genRamContents memDepth = genSomeVec (Range.singleton $ fromIntegral (memDepth - 1)) @@ -87,20 +120,29 @@ genRamContents memDepth = genSomeVec (Range.singleton $ fromIntegral (memDepth - readDoubleBufferedRam :: Property readDoubleBufferedRam = property $ do ramDepth <- forAll . Gen.int $ Range.constant 1 31 - ramContents <- forAll $ genRamContents ramDepth - $ genUnsigned @_ @64 Range.constantBounded + ramContents <- + forAll + $ genRamContents ramDepth + $ genUnsigned @_ @64 Range.constantBounded case ramContents of - SomeVec SNat (contentsSingle :: Vec (n+1) (Unsigned 64)) -> do + SomeVec SNat (contentsSingle :: Vec (n + 1) (Unsigned 64)) -> do simLength <- forAll $ Gen.int (Range.constant 1 100) let contentsDouble = concatMap (replicate d2) contentsSingle simRange = Range.singleton simLength - switchSignal <- forAll $ Gen.list simRange (Gen.element [A,B]) + switchSignal <- forAll $ Gen.list simRange (Gen.element [A, B]) readAddresses <- forAll . Gen.list simRange . genIndex $ Range.constantBounded let - topEntity (unbundle -> (switch, readAddr)) = withClockResetEnable @System clockGen - resetGen enableGen $ doubleBufferedRam @_ @(n+1) (Vec contentsDouble) - switch readAddr (pure Nothing) + topEntity (unbundle -> (switch, readAddr)) = + withClockResetEnable @System + clockGen + resetGen + enableGen + $ doubleBufferedRam @_ @(n + 1) + (Vec contentsDouble) + switch + readAddr + (pure Nothing) topEntityInput = P.zip switchSignal readAddresses simOut = P.tail $ simulateN simLength topEntity topEntityInput expectedOut = fmap (contentsSingle !!) readAddresses @@ -110,25 +152,39 @@ readDoubleBufferedRam = property $ do readWriteDoubleBufferedRam :: Property readWriteDoubleBufferedRam = property $ do ramDepth <- forAll $ Gen.enum 1 31 - ramContents <- forAll $ genRamContents ramDepth $ - genUnsigned @_ @64 Range.constantBounded + ramContents <- + forAll + $ genRamContents ramDepth + $ genUnsigned @_ @64 Range.constantBounded let minSimLength = 2 * ramDepth simLength <- forAll $ Gen.int (Range.constant minSimLength 100) case ramContents of - SomeVec SNat (contentsSingle :: Vec (n+1) (Unsigned 64)) -> do + SomeVec SNat (contentsSingle :: Vec (n + 1) (Unsigned 64)) -> do let contentsDouble = concatMap (replicate d2) contentsSingle - topEntity (unbundle -> (switch, readAddr, writePort)) = withClockResetEnable - @System clockGen resetGen enableGen $ doubleBufferedRam @_ @(n+1) - (Vec contentsDouble) switch readAddr writePort + topEntity (unbundle -> (switch, readAddr, writePort)) = + withClockResetEnable + @System + clockGen + resetGen + enableGen + $ doubleBufferedRam @_ @(n + 1) + (Vec contentsDouble) + switch + readAddr + writePort let - addresses = cycle $ fmap fromIntegral [0..ramDepth-1] + addresses = cycle $ fmap fromIntegral [0 .. ramDepth - 1] switchSignal = cycle $ L.replicate ramDepth A <> L.replicate ramDepth B - writeEntries <- forAll (Gen.list (Range.singleton simLength) - $ genUnsigned Range.constantBounded) + writeEntries <- + forAll + ( Gen.list (Range.singleton simLength) + $ genUnsigned Range.constantBounded + ) let - topEntityInput = L.zip3 switchSignal addresses - $ fmap Just (P.zip addresses writeEntries) + topEntityInput = + L.zip3 switchSignal addresses + $ fmap Just (P.zip addresses writeEntries) simOut = simulateN @System simLength topEntity topEntityInput expected = toList contentsSingle <> L.take (simLength - ramDepth - 1) writeEntries Set.fromList simOut === Set.fromList expected @@ -147,19 +203,22 @@ instance Show BitvecVec where genBlockRamContents :: Int -> Int -> Gen BitvecVec genBlockRamContents memDepth bits = do case ( TN.someNatVal $ fromIntegral (memDepth - 1) - , TN.someNatVal $ fromIntegral $ bits - 1) of + , TN.someNatVal $ fromIntegral $ bits - 1 + ) of (SomeNat depth0, SomeNat bits0) -> go (snatProxy depth0) (snatProxy bits0) where - go :: forall memDepth bits . SNat memDepth -> SNat bits -> Gen BitvecVec + go :: forall memDepth bits. SNat memDepth -> SNat bits -> Gen BitvecVec go depth0@SNat bits0@SNat = case compareSNat d1 (SNat @(Regs (BitVector (bits + 1)) 8)) of - SNatLE -> BitvecVec (succSNat depth0) (succSNat bits0) - <$> genNonEmptyVec genDefinedBitVector + SNatLE -> + BitvecVec (succSNat depth0) (succSNat bits0) + <$> genNonEmptyVec genDefinedBitVector _ -> error "genBlockRamContents: Generated BitVector is of size 0." --- | This test checks if we can write new values to the byte addressable 'blockRam' --- ('blockRamByteAddressable') and read them. It uses 'byteAddressableRamBehavior' as- --- reference model. +{- | This test checks if we can write new values to the byte addressable 'blockRam' +('blockRamByteAddressable') and read them. It uses 'byteAddressableRamBehavior' as- +reference model. +-} readWriteByteAddressableBlockram :: Property readWriteByteAddressableBlockram = property $ do ramDepth <- forAll $ Gen.enum 1 31 @@ -171,27 +230,41 @@ readWriteByteAddressableBlockram = property $ do let simRange = Range.singleton simLength topEntity (unbundle -> (readAddr, writePort, byteSelect)) = - withClockResetEnable clockGen resetGen enableGen - blockRamByteAddressable (Vec contents) readAddr writePort byteSelect + withClockResetEnable + clockGen + resetGen + enableGen + blockRamByteAddressable + (Vec contents) + readAddr + writePort + byteSelect writeAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded readAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded writeEntries <- forAll (Gen.list simRange $ Gen.maybe genDefinedBitVector) byteSelectSignal <- forAll $ Gen.list simRange genDefinedBitVector let - topEntityInput = L.zip3 readAddresses - (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) byteSelectSignal + topEntityInput = + L.zip3 + readAddresses + (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) + byteSelectSignal simOut = simulateN @System simLength topEntity topEntityInput - (_,expectedOut) = L.mapAccumL byteAddressableRamBehavior - (L.head topEntityInput, contents) $ L.tail topEntityInput + (_, expectedOut) = + L.mapAccumL + byteAddressableRamBehavior + (L.head topEntityInput, contents) + $ L.tail topEntityInput -- TODO: Due to some unexpected mismatch between the expected behavior of either -- blockRam or the behavioral model, the boot behavior is inconsistent. We drop the first -- expectedOutput cycle too, we expect this is due to the resets supplied b simulateN. -- An issue has been made regarding this. L.drop 2 simOut === L.tail expectedOut --- | This test checks if 'blockRamByteAddressable' behaves the same as 'blockRam' when the --- byteEnables are always high. +{- | This test checks if 'blockRamByteAddressable' behaves the same as 'blockRam' when the +byteEnables are always high. +-} byteAddressableBlockRamAsBlockRam :: Property byteAddressableBlockRamAsBlockRam = property $ do ramDepth <- forAll $ Gen.enum 1 31 @@ -204,22 +277,27 @@ byteAddressableBlockRamAsBlockRam = property $ do simRange = Range.singleton simLength -- topEntity returns a tuple with the outputs of (byteAddressableRam,blockRam) topEntity (unbundle -> (readAddr, writePort)) = - withClockResetEnable clockGen resetGen enableGen $ bundle - ( blockRamByteAddressable (Vec contents) readAddr writePort (pure maxBound) - , blockRam contents readAddr writePort) + withClockResetEnable clockGen resetGen enableGen + $ bundle + ( blockRamByteAddressable (Vec contents) readAddr writePort (pure maxBound) + , blockRam contents readAddr writePort + ) writeAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded readAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded writeEntries <- forAll (Gen.list simRange $ Gen.maybe genDefinedBitVector) let - topEntityInput = L.zip readAddresses - (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) - simOut = simulateN @System simLength topEntity topEntityInput + topEntityInput = + L.zip + readAddresses + (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) + simOut = simulateN @System simLength topEntity topEntityInput (fstOut, sndOut) = L.unzip simOut footnote . fromString $ "simOut: " <> showX simOut fstOut === sndOut --- | This test checks if we can write new values to the byte addressable double buffered --- 'blockRam' ('doubleBufferedRamByteAddressable') and read them. +{- | This test checks if we can write new values to the byte addressable double buffered +'blockRam' ('doubleBufferedRamByteAddressable') and read them. +-} doubleBufferedRamByteAddressable0 :: Property doubleBufferedRamByteAddressable0 = property $ do ramDepth <- forAll $ Gen.enum 1 31 @@ -233,27 +311,39 @@ doubleBufferedRamByteAddressable0 = property $ do simRange = Range.singleton simLength topEntity (unbundle -> (switch, readAddr, writePort, byteSelect)) = withClockResetEnable @System clockGen resetGen enableGen - $ doubleBufferedRamByteAddressable (Vec contentsDouble) - switch readAddr writePort byteSelect + $ doubleBufferedRamByteAddressable + (Vec contentsDouble) + switch + readAddr + writePort + byteSelect writeAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded readAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded writeEntries <- forAll (Gen.list simRange $ Gen.maybe genDefinedBitVector) byteSelectSignal <- forAll $ Gen.list simRange genDefinedBitVector - switchSignal <- forAll $ Gen.list simRange (Gen.element [A,B]) + switchSignal <- forAll $ Gen.list simRange (Gen.element [A, B]) let - topEntityInput = L.zip4 switchSignal readAddresses - (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) byteSelectSignal + topEntityInput = + L.zip4 + switchSignal + readAddresses + (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) + byteSelectSignal simOut = simulateN @System simLength topEntity topEntityInput - (_,expectedOut) = L.mapAccumL byteAddressableDoubleBufferedRamBehavior - (L.head topEntityInput, contentsSingle, contentsSingle) $ L.tail topEntityInput + (_, expectedOut) = + L.mapAccumL + byteAddressableDoubleBufferedRamBehavior + (L.head topEntityInput, contentsSingle, contentsSingle) + $ L.tail topEntityInput -- TODO: Due to some unexpected mismatch between the expected behavior of either -- blockRam or the behavioral model, the boot behavior is inconsistent. We drop the first -- expectedOutput cycle too, we expect this is due to the resets supplied b simulateN. -- An issue has been made regarding this. L.drop 2 simOut === L.tail expectedOut --- | This test checks if 'doubleBufferedRamByteAddressable' behaves the same as --- 'doubleBufferedRam' when the byteEnables are always high. +{- | This test checks if 'doubleBufferedRamByteAddressable' behaves the same as +'doubleBufferedRam' when the byteEnables are always high. +-} doubleBufferedRamByteAddressable1 :: Property doubleBufferedRamByteAddressable1 = property $ do ramDepth <- forAll $ Gen.enum 1 31 @@ -266,22 +356,33 @@ doubleBufferedRamByteAddressable1 = property $ do contentsDouble = concatMap (replicate d2) contentsSingle simRange = Range.singleton simLength topEntity (unbundle -> (switch, readAddr, writePort)) = - withClockResetEnable @System clockGen resetGen enableGen $ bundle - ( doubleBufferedRamByteAddressable (Vec contentsDouble) switch readAddr writePort (pure maxBound) - , doubleBufferedRam (Vec contentsDouble) switch readAddr writePort) + withClockResetEnable @System clockGen resetGen enableGen + $ bundle + ( doubleBufferedRamByteAddressable + (Vec contentsDouble) + switch + readAddr + writePort + (pure maxBound) + , doubleBufferedRam (Vec contentsDouble) switch readAddr writePort + ) writeAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded readAddresses <- forAll $ Gen.list simRange $ genIndex Range.constantBounded writeEntries <- forAll (Gen.list simRange $ Gen.maybe genDefinedBitVector) - switchSignal <- forAll $ Gen.list simRange (Gen.element [A,B]) + switchSignal <- forAll $ Gen.list simRange (Gen.element [A, B]) let - topEntityInput = L.zip3 switchSignal readAddresses - (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) + topEntityInput = + L.zip3 + switchSignal + readAddresses + (P.zipWith (\adr wr -> (adr,) <$> wr) writeAddresses writeEntries) simOut = simulateN @System simLength topEntity topEntityInput (duvOut, refOut) = L.unzip simOut duvOut === refOut --- | This test checks that we can generate a 'registerByteAddressable' that stores a --- configurable amount of bytes and selectively update its contents on a per byte basis. +{- | This test checks that we can generate a 'registerByteAddressable' that stores a +configurable amount of bytes and selectively update its contents on a per byte basis. +-} readWriteRegisterByteAddressable :: Property readWriteRegisterByteAddressable = property $ do nBytes <- forAll $ Gen.enum 1 10 @@ -291,10 +392,13 @@ readWriteRegisterByteAddressable = property $ do _ -> error "readWriteRegisterByteAddressable: Amount of nBytes == 0." where go :: - forall nBytes m . + forall nBytes m. ( KnownNat nBytes - , 1 <= nBytes, KnownNat (nBytes*8) - , 1 <= (nBytes * 8), Monad m) => + , 1 <= nBytes + , KnownNat (nBytes * 8) + , 1 <= (nBytes * 8) + , Monad m + ) => Proxy nBytes -> PropertyT m () go Proxy = @@ -305,23 +409,27 @@ readWriteRegisterByteAddressable = property $ do writeGen = genNonEmptyVec @_ @nBytes $ genDefinedBitVector @8 initVal <- forAll writeGen writes <- forAll $ Gen.list (Range.singleton simLength) writeGen - byteEnables <- forAll $ Gen.list (Range.singleton simLength) - $ genDefinedBitVector @(Regs (Vec nBytes Byte) 8) + byteEnables <- + forAll + $ Gen.list (Range.singleton simLength) + $ genDefinedBitVector @(Regs (Vec nBytes Byte) 8) let - topEntity (unbundle -> (newVal, byteEnable))= - withClockResetEnable @System clockGen resetGen enableGen $ - registerByteAddressable initVal newVal byteEnable + topEntity (unbundle -> (newVal, byteEnable)) = + withClockResetEnable @System clockGen resetGen enableGen + $ registerByteAddressable initVal newVal byteEnable expectedOut = P.scanl useByteEnable initVal $ P.zip writes byteEnables - useByteEnable olds (news,unpack -> enables) = - (\(enable,old,new) -> if enable then new else old) <$> zip3 enables olds news + useByteEnable olds (news, unpack -> enables) = + (\(enable, old, new) -> if enable then new else old) <$> zip3 enables olds news simOut = simulateN simLength topEntity $ P.zip writes byteEnables simOut === P.take simLength expectedOut - _ -> error "readWriteRegisterByteAddressable: Amount of bytes not equal to registers required." - --- | This test checks that 'registerWb' can be written to and read from via its wishbone bus. --- This test makes sure that writing and reading with the wishbone bus works both with --- 'CircuitPriority' and 'WishbonePriority' enabled. During this test the circuit input does --- not write to the register. + _ -> + error "readWriteRegisterByteAddressable: Amount of bytes not equal to registers required." + +{- | This test checks that 'registerWb' can be written to and read from via its wishbone bus. +This test makes sure that writing and reading with the wishbone bus works both with +'CircuitPriority' and 'WishbonePriority' enabled. During this test the circuit input does +not write to the register. +-} registerWbSigToSig :: Property registerWbSigToSig = property $ do bits <- forAll $ Gen.enum 1 100 @@ -330,15 +438,17 @@ registerWbSigToSig = property $ do SNatLE -> go p _ -> error "registerWbSigToSig: Amount of bits == 0." where - go :: forall bits m . (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () + go :: forall bits m. (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () go Proxy = case compareSNat d1 $ SNat @(Regs (BitVector bits) 32) of SNatLE -> do initVal <- forAll $ genDefinedBitVector @bits writes <- forAll $ Gen.list (Range.constant 1 25) $ genDefinedBitVector @bits let simLength = L.length writes + 1 - someReg prio sigIn = fst $ withClockResetEnable clockGen resetGen enableGen - $ registerWbSpecVal @_ @_ @4 @32 prio initVal (pure emptyWishboneM2S) sigIn + someReg prio sigIn = + fst + $ withClockResetEnable clockGen resetGen enableGen + $ registerWbSpecVal @_ @_ @4 @32 prio initVal (pure emptyWishboneM2S) sigIn topEntity sigIn = bundle (someReg CircuitPriority sigIn, someReg WishbonePriority sigIn) topEntityInput = (Just <$> writes) <> [Nothing] simOut = simulateN @System simLength topEntity topEntityInput @@ -350,10 +460,11 @@ registerWbSigToSig = property $ do writes === L.tail fstOut _ -> error "registerWbSigToSig: Registers required to store bitvector == 0." --- | This test checks that 'registerWb' can be written to with the wishbone bus and read from --- with the circuit output. This test makes sure that the behavior with 'CircuitPriority' --- and 'WishbonePriority' is identical. During this test the circuit input does not write --- to the register. +{- | This test checks that 'registerWb' can be written to with the wishbone bus and read from +with the circuit output. This test makes sure that the behavior with 'CircuitPriority' +and 'WishbonePriority' is identical. During this test the circuit input does not write +to the register. +-} registerWbWbToSig :: Property registerWbWbToSig = property $ do bits <- forAll $ Gen.enum 1 100 @@ -362,7 +473,7 @@ registerWbWbToSig = property $ do SNatLE -> go p _ -> error "registerWbWbToSig: Amount of bits == 0." where - go :: forall bits m . (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () + go :: forall bits m. (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () go Proxy = case compareSNat d1 $ SNat @(Regs (BitVector bits) 32) of SNatLE -> do let regs = (natToNum @(DivRU bits 32)) @@ -370,8 +481,10 @@ registerWbWbToSig = property $ do writes <- forAll $ Gen.list (Range.constant 1 25) $ genDefinedBitVector @bits let simLength = L.length writes * regs + 2 - someReg prio wbIn = fst $ withClockResetEnable clockGen resetGen enableGen $ - registerWbSpecVal @System @_ @4 @32 prio initVal wbIn (pure Nothing) + someReg prio wbIn = + fst + $ withClockResetEnable clockGen resetGen enableGen + $ registerWbSpecVal @System @_ @4 @32 prio initVal wbIn (pure Nothing) topEntity wbIn = bundle (someReg CircuitPriority wbIn, someReg WishbonePriority wbIn) topEntityInput = L.concatMap wbWrite writes <> L.repeat emptyWishboneM2S simOut = simulateN simLength topEntity topEntityInput @@ -386,18 +499,20 @@ registerWbWbToSig = property $ do writes === L.take (L.length writes) filteredOut _ -> error "registerWbWbToSig: Registers required to store bitvector == 0." where - wbWrite v = L.zipWith bv2WbWrite [0.. L.length l - 1] l + wbWrite v = L.zipWith bv2WbWrite [0 .. L.length l - 1] l where RegisterBank (toList -> l) = getRegsLe v - everyNth n l | L.length l >= n = L.head xs : everyNth n (L.tail xs) - | otherwise = [] + everyNth n l + | L.length l >= n = L.head xs : everyNth n (L.tail xs) + | otherwise = [] where - xs = L.drop (n-1) l + xs = L.drop (n - 1) l --- | This test checks that 'registerWb' can be written to by the circuit and read from --- with the wishbone bus. This test makes sure that the behavior with 'CircuitPriority' --- and 'WishbonePriority' is identical. During this test the wishbone bus does not write --- to the register. +{- | This test checks that 'registerWb' can be written to by the circuit and read from +with the wishbone bus. This test makes sure that the behavior with 'CircuitPriority' +and 'WishbonePriority' is identical. During this test the wishbone bus does not write +to the register. +-} registerWbSigToWb :: Property registerWbSigToWb = property $ do bits <- forAll $ Gen.enum 1 100 @@ -406,19 +521,24 @@ registerWbSigToWb = property $ do SNatLE -> go p _ -> error "registerWbSigToWb: Amount of bits == 0." where - go :: forall bits m . (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () + go :: forall bits m. (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () go Proxy = case compareSNat d1 $ SNat @(Regs (BitVector bits) 32) of SNatLE -> do initVal <- forAll $ genDefinedBitVector @bits writes <- forAll $ Gen.list (Range.constant 1 25) $ genDefinedBitVector @bits let - someReg prio sigIn wbIn = snd $ withClockResetEnable clockGen resetGen enableGen - $ registerWbSpecVal @_ @_ @4 @32 prio initVal wbIn sigIn - topEntity (unbundle -> (sigIn, wbIn)) = bundle - (someReg CircuitPriority sigIn wbIn, someReg WishbonePriority sigIn wbIn) + someReg prio sigIn wbIn = + snd + $ withClockResetEnable clockGen resetGen enableGen + $ registerWbSpecVal @_ @_ @4 @32 prio initVal wbIn sigIn + topEntity (unbundle -> (sigIn, wbIn)) = + bundle + (someReg CircuitPriority sigIn wbIn, someReg WishbonePriority sigIn wbIn) padWrites x = L.take (natToNum @(Regs (BitVector bits) 32)) $ Just x : L.repeat Nothing - readOps = emptyWishboneM2S : cycle - (wbRead <$> [(0 :: Int).. (natToNum @(Regs (BitVector bits) 32)-1)]) + readOps = + emptyWishboneM2S + : cycle + (wbRead <$> [(0 :: Int) .. (natToNum @(Regs (BitVector bits) 32) - 1)]) topEntityInput = L.zip (L.concatMap padWrites writes <> [Nothing]) readOps simLength = L.length topEntityInput simOut = simulateN @System simLength topEntity topEntityInput @@ -431,37 +551,41 @@ registerWbSigToWb = property $ do _ -> error "registerWbSigToWb: Registers required to store bitvector == 0." where wbDecoding :: ([WishboneS2M (BitVector 32)] -> [BitVector bits]) - wbDecoding (wbNow:wbRest) + wbDecoding (wbNow : wbRest) | acknowledge wbNow = entry : wbDecoding rest - | otherwise = wbDecoding wbRest + | otherwise = wbDecoding wbRest where (fmap readData -> entryList, rest) = - L.splitAt (natToNum @(Regs (BitVector bits) 32)) (wbNow:wbRest) + L.splitAt (natToNum @(Regs (BitVector bits) 32)) (wbNow : wbRest) entry = case V.fromList entryList of - Just (vec :: Vec (Regs (BitVector bits) 32) (BitVector 32)) - -> getDataLe @32 (RegisterBank vec) - Nothing - -> error $ "wbDecoding: list to vector conversion failed: " - <> show entryList <> "from " <> show (wbNow:wbRest) - + Just (vec :: Vec (Regs (BitVector bits) 32) (BitVector 32)) -> + getDataLe @32 (RegisterBank vec) + Nothing -> + error + $ "wbDecoding: list to vector conversion failed: " + <> show entryList + <> "from " + <> show (wbNow : wbRest) wbDecoding [] = [] - wbRead i = (emptyWishboneM2S @32) - { addr = resize (pack i) ++# (0b00 :: BitVector 2) - , busCycle = True - , busSelect = maxBound - , strobe = True - } + wbRead i = + (emptyWishboneM2S @32) + { addr = resize (pack i) ++# (0b00 :: BitVector 2) + , busCycle = True + , busSelect = maxBound + , strobe = True + } postProcWb (WishboneS2M{..} : wbRest) | acknowledge = Just readData : postProcWb wbRest - | err = Nothing : postProcWb wbRest - | otherwise = postProcWb wbRest + | err = Nothing : postProcWb wbRest + | otherwise = postProcWb wbRest postProcWb _ = [] --- | This test checks that the behavior of 'registerWb' matches the set priorities when --- a write conflict occurs. It is expected that with 'WishbonePriority', the circuit --- ignores write operations from the circuit during a wishbone write operation. --- With 'CircuitPriority', wishbone write operations are acknowledged, but silently --- ignored during a circuit write cycle. +{- | This test checks that the behavior of 'registerWb' matches the set priorities when +a write conflict occurs. It is expected that with 'WishbonePriority', the circuit +ignores write operations from the circuit during a wishbone write operation. +With 'CircuitPriority', wishbone write operations are acknowledged, but silently +ignored during a circuit write cycle. +-} registerWbWriteCollisions :: Property registerWbWriteCollisions = property $ do bits <- forAll $ Gen.enum 1 32 @@ -470,7 +594,7 @@ registerWbWriteCollisions = property $ do SNatLE -> go p _ -> error "registerWbWriteCollisions: Amount of bits == 0." where - go :: forall bits m . (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () + go :: forall bits m. (KnownNat bits, 1 <= bits, Monad m) => Proxy bits -> PropertyT m () go Proxy = case compareSNat d1 $ SNat @(Regs (BitVector bits) 32) of SNatLE -> do initVal <- forAll $ genDefinedBitVector @bits @@ -479,12 +603,17 @@ registerWbWriteCollisions = property $ do wbWrites <- forAll $ Gen.list (Range.singleton writeAmount) $ genDefinedBitVector @bits let simLength = writeAmount + 1 - someReg prio sigIn wbIn = fst $ withClockResetEnable clockGen resetGen enableGen $ - registerWbSpecVal @System @_ @4 @32 prio initVal wbIn sigIn - topEntity (unbundle -> (sigIn, wbIn)) = bundle - (someReg CircuitPriority sigIn wbIn, someReg WishbonePriority sigIn wbIn) - topEntityInput = L.zip (Just <$> sigWrites) - (L.concatMap wbWrite wbWrites <> L.repeat emptyWishboneM2S) + someReg prio sigIn wbIn = + fst + $ withClockResetEnable clockGen resetGen enableGen + $ registerWbSpecVal @System @_ @4 @32 prio initVal wbIn sigIn + topEntity (unbundle -> (sigIn, wbIn)) = + bundle + (someReg CircuitPriority sigIn wbIn, someReg WishbonePriority sigIn wbIn) + topEntityInput = + L.zip + (Just <$> sigWrites) + (L.concatMap wbWrite wbWrites <> L.repeat emptyWishboneM2S) simOut = simulateN simLength topEntity topEntityInput (fstOut, sndOut) = L.unzip simOut @@ -494,45 +623,54 @@ registerWbWriteCollisions = property $ do footnote . fromString $ "wbIn" <> showX wbWrites footnote . fromString $ "sigIn" <> showX sigWrites sigWrites === L.tail fstOut - wbWrites === L.tail sndOut + wbWrites === L.tail sndOut _ -> error "registerWbWriteCollisions: Registers required to store bitvector == 0." where - wbWrite v = L.zipWith bv2WbWrite (L.reverse [0.. L.length l - 1]) l + wbWrite v = L.zipWith bv2WbWrite (L.reverse [0 .. L.length l - 1]) l where RegisterBank (toList -> l) = getRegsLe v -bv2WbWrite :: (BitPack a, Enum a) => - a - -> ("DAT_MOSI" ::: BitVector 32) - -> WishboneM2S 32 4 (BitVector 32) -bv2WbWrite i v = (emptyWishboneM2S @32 @(BitVector 32)) - { addr = resize (pack i) ++# (0b00 :: BitVector 2) - , writeData = v - , writeEnable = True - , busCycle = True - , strobe = True - , busSelect = maxBound - } - --- | Model for 'byteAddressableRam', it stores the inputs in its state for a one cycle delay --- and updates the Ram based on the the write operation and byte enables. --- Furthermore it contains read-before-write behavior based on the readAddr. -byteAddressableRamBehavior :: forall bits memDepth nBytes . - (KnownNat memDepth, 1 <= memDepth - , KnownNat nBytes, 1 <= nBytes +bv2WbWrite :: + (BitPack a, Enum a) => + a -> + ("DAT_MOSI" ::: BitVector 32) -> + WishboneM2S 32 4 (BitVector 32) +bv2WbWrite i v = + (emptyWishboneM2S @32 @(BitVector 32)) + { addr = resize (pack i) ++# (0b00 :: BitVector 2) + , writeData = v + , writeEnable = True + , busCycle = True + , strobe = True + , busSelect = maxBound + } + +{- | Model for 'byteAddressableRam', it stores the inputs in its state for a one cycle delay +and updates the Ram based on the the write operation and byte enables. +Furthermore it contains read-before-write behavior based on the readAddr. +-} +byteAddressableRamBehavior :: + forall bits memDepth nBytes. + ( KnownNat memDepth + , 1 <= memDepth + , KnownNat nBytes + , 1 <= nBytes , nBytes ~ Regs (BitVector bits) 8 - , KnownNat bits, 1 <= bits) => - - ((Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) - , Vec memDepth (BitVector bits))-> - + , KnownNat bits + , 1 <= bits + ) => + ( (Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) + , Vec memDepth (BitVector bits) + ) -> (Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) -> - - ((( Index memDepth - , Maybe (LocatedBits memDepth bits) - , BitVector nBytes) - , Vec memDepth (BitVector bits)) - , BitVector bits) + ( ( ( Index memDepth + , Maybe (LocatedBits memDepth bits) + , BitVector nBytes + ) + , Vec memDepth (BitVector bits) + ) + , BitVector bits + ) byteAddressableRamBehavior state input = (state', ram !! readAddr) where ((readAddr, writeOp, byteEnable), ram) = state @@ -540,41 +678,50 @@ byteAddressableRamBehavior state input = (state', ram !! readAddr) writeTrue = isJust writeOp RegisterBank oldData = getRegsBe $ ram !! writeAddr RegisterBank newData = getRegsBe writeData0 - newEntry = getDataBe @8 . RegisterBank $ zipWith - (\ sel (old,new) -> if sel then new else old) - (unpack byteEnable) (zip oldData newData) + newEntry = + getDataBe @8 + . RegisterBank + $ zipWith + (\sel (old, new) -> if sel then new else old) + (unpack byteEnable) + (zip oldData newData) ram1 = if writeTrue then replace writeAddr newEntry ram else ram state' = (input, ram1) --- | Model for 'byteAddressableDoubleBufferedRamBehavior', it stores the inputs in its --- state for a one cycle delay and updates the Ram based on the the write operation and --- byte enables. Furthermore it contains read-before-write behavior based on the readAddr. --- The only addition compared to byteAddressableRam is the fact that there's two buffers --- (one read only, one write only), that can be swapped. -byteAddressableDoubleBufferedRamBehavior :: forall bits memDepth nBytes . - ( KnownNat memDepth - , 1 <= memDepth - , KnownNat nBytes - , 1 <= nBytes - , nBytes ~ Regs (BitVector bits) 8 - , KnownNat bits - , 1 <= bits) => - ((AorB, Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) - , Vec memDepth (BitVector bits), Vec memDepth (BitVector bits))-> - - (AorB, Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) -> - - (((AorB, Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) - , Vec memDepth (BitVector bits) - , Vec memDepth (BitVector bits)) - , BitVector bits) +{- | Model for 'byteAddressableDoubleBufferedRamBehavior', it stores the inputs in its +state for a one cycle delay and updates the Ram based on the the write operation and +byte enables. Furthermore it contains read-before-write behavior based on the readAddr. +The only addition compared to byteAddressableRam is the fact that there's two buffers +(one read only, one write only), that can be swapped. +-} +byteAddressableDoubleBufferedRamBehavior :: + forall bits memDepth nBytes. + ( KnownNat memDepth + , 1 <= memDepth + , KnownNat nBytes + , 1 <= nBytes + , nBytes ~ Regs (BitVector bits) 8 + , KnownNat bits + , 1 <= bits + ) => + ( (AorB, Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) + , Vec memDepth (BitVector bits) + , Vec memDepth (BitVector bits) + ) -> + (AorB, Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) -> + ( ( (AorB, Index memDepth, Maybe (LocatedBits memDepth bits), BitVector nBytes) + , Vec memDepth (BitVector bits) + , Vec memDepth (BitVector bits) + ) + , BitVector bits + ) byteAddressableDoubleBufferedRamBehavior state input = (state', out) where ((switchBuffers, readAddr, writeOp, byteEnable), bufA0, bufB0) = state (out, bufA1, bufB1) | switchBuffers == B = (bufA0 !! readAddr, bufA0, updateEntry bufB0 writeOp) - | otherwise = (bufB0 !! readAddr, updateEntry bufA0 writeOp, bufB0) + | otherwise = (bufB0 !! readAddr, updateEntry bufA0 writeOp, bufB0) updateEntry buf op | isJust writeOp = replace writeAddr newEntry buf @@ -583,20 +730,24 @@ byteAddressableDoubleBufferedRamBehavior state input = (state', out) newEntry = getNewEntry (buf !! writeAddr) writeData0 (writeAddr, writeData0) = fromMaybe (0, 0) op - getNewEntry old new = getDataBe @8 . RegisterBank $ zipWith - (\ sel (a,b) -> if sel then b else a) - (unpack byteEnable) $ zip oldData newData + getNewEntry old new = + getDataBe @8 + . RegisterBank + $ zipWith + (\sel (a, b) -> if sel then b else a) + (unpack byteEnable) + $ zip oldData newData where RegisterBank oldData = getRegsBe old RegisterBank newData = getRegsBe new state' = (input, bufA1, bufB1) - --- | Version of 'Bittide.DoubleBufferedRam.registerWb' which performs wishbone --- spec validation. +{- | Version of 'Bittide.DoubleBufferedRam.registerWb' which performs wishbone + spec validation. +-} registerWbSpecVal :: - forall dom a nBytes addrW . + forall dom a nBytes addrW. ( HiddenClockResetEnable dom , Paddable a , KnownNat nBytes @@ -604,7 +755,8 @@ registerWbSpecVal :: , KnownNat addrW , 2 <= addrW , BitPack a - , ShowX a) => + , ShowX a + ) => -- | Determines the write priority on write collisions RegisterWritePriority -> -- | Initial value. @@ -622,8 +774,9 @@ registerWbSpecVal writePriority initVal m2s0 sigIn = (storedVal, s2m1) (storedVal, s2m0) = registerWb @dom @a @nBytes @addrW writePriority initVal m2s1 sigIn (m2s1, s2m1) = validateWb m2s0 s2m0 --- | Generate an input vector for 'contentGenerator' and check if it generates write --- operations from this vector. +{- | Generate an input vector for 'contentGenerator' and check if it generates write +operations from this vector. +-} testContentGen :: Property testContentGen = property $ do nat <- forAll $ Gen.enum 0 32 @@ -635,8 +788,11 @@ testContentGen = property $ do let l = length content simLength = 2 + l * 2 - !(writes, dones) = L.unzip $ sampleN @System simLength - (bundle $ contentGenerator @_ @v @(v +1) (Vec content)) + !(writes, dones) = + L.unzip + $ sampleN @System + simLength + (bundle $ contentGenerator @_ @v @(v + 1) (Vec content)) expectedDones | l == 0 = L.repeat True | otherwise = L.replicate (l + 2) False <> L.repeat True @@ -648,31 +804,34 @@ wbStorageSpecCompliance = property $ do nat <- forAll $ Gen.enum 1 32 case TN.someNatVal (nat - 1) of SomeNat (succSNat . snatProxy -> n) -> go n - - where - go :: forall v m . (KnownNat v, 1 <= v, Monad m) => SNat v -> PropertyT m () - go SNat = do - content <- forAll $ genNonEmptyVec @_ @v (genDefinedBitVector @32) - wcre $ wishbonePropWithModel @System + where + go :: forall v m. (KnownNat v, 1 <= v, Monad m) => SNat v -> PropertyT m () + go SNat = do + content <- forAll $ genNonEmptyVec @_ @v (genDefinedBitVector @32) + wcre + $ wishbonePropWithModel @System defExpectOptions (\_ _ () -> Right ()) (wbStorage (Reloadable $ Vec content)) (genRequests (snatToNum (SNat @v) - 1)) () - genRequests size = Gen.list (Range.linear 0 32) + genRequests size = + Gen.list + (Range.linear 0 32) (genWishboneTransfer @32 size (genDefinedBitVector @32)) - genWishboneTransfer :: - (KnownNat addressWidth, KnownNat (BitSize a)) => - Int -> -- ^ size - Gen a -> - Gen (WishboneMasterRequest addressWidth a) - genWishboneTransfer size genA = - let - validAddr = (4*) . fromIntegral <$> Gen.enum 0 (size - 1) - invalidAddr = fromIntegral <$> Gen.enum (size * 4) (size * 8) - in + genWishboneTransfer :: + (KnownNat addressWidth, KnownNat (BitSize a)) => + Int -> + -- \^ size + Gen a -> + Gen (WishboneMasterRequest addressWidth a) + genWishboneTransfer size genA = + let + validAddr = (4 *) . fromIntegral <$> Gen.enum 0 (size - 1) + invalidAddr = fromIntegral <$> Gen.enum (size * 4) (size * 8) + in Gen.choice [ Read <$> validAddr <*> pure (succ 0) , Write <$> validAddr <*> pure (succ 0) <*> genA @@ -680,21 +839,26 @@ wbStorageSpecCompliance = property $ do , Write <$> invalidAddr <*> pure (succ 0) <*> genA ] -deriving instance ShowX a => ShowX (RamOp i a) +deriving instance (ShowX a) => ShowX (RamOp i a) --- | Behavioral test for 'wbStorage', it checks whether the behavior of 'wbStorage' matches --- the 'wbStorageBehaviorModel'. +{- | Behavioral test for 'wbStorage', it checks whether the behavior of 'wbStorage' matches +the 'wbStorageBehaviorModel'. +-} wbStorageBehavior :: Property wbStorageBehavior = property $ do nWords <- forAll $ Gen.enum 2 32 case TN.someNatVal (nWords - 2) of SomeNat (addSNat d2 . snatProxy -> nWords0) -> go nWords0 where - go :: forall words m . (KnownNat words, 2 <= words, Monad m) => SNat words -> PropertyT m () + go :: + forall words m. (KnownNat words, 2 <= words, Monad m) => SNat words -> PropertyT m () go SNat = do content <- forAll $ genVec @_ @words genDefinedBitVector - wbRequests <- forAll $ Gen.list (Range.linear 0 32) - (genWishboneTransfer @32 (natToNum @words) (genDefinedBitVector @32)) + wbRequests <- + forAll + $ Gen.list + (Range.linear 0 32) + (genWishboneTransfer @32 (natToNum @words) (genDefinedBitVector @32)) let master = driveStandard defExpectOptions $ fmap snd wbRequests @@ -710,33 +874,34 @@ wbStorageBehavior = property $ do where genWishboneTransfer :: (KnownNat addressWidth, KnownNat (BitSize a)) => - Int -> -- ^ size + Int -> + -- \^ size Gen a -> - Gen (Bool,(WishboneMasterRequest addressWidth a, Int)) + Gen (Bool, (WishboneMasterRequest addressWidth a, Int)) genWishboneTransfer size genA = let validAddr = (4 *) . fromIntegral <$> Gen.enum 0 (size - 1) - invalidAddr = Gen.choice - [ fromIntegral <$> Gen.enum (size * 4) (size * 8) - , (+) <$> validAddr <*> (Gen.enum 1 3) - ] + invalidAddr = + Gen.choice + [ fromIntegral <$> Gen.enum (size * 4) (size * 8) + , (+) <$> validAddr <*> (Gen.enum 1 3) + ] -- Make wbOps that won't be repeated mkRead address bs = (Read address bs, 0) mkWrite address bs a = (Write address bs a, 0) - in + in -- Generate valid and invalid operations. The boolean represents the validity of the operation. - Gen.choice - [ (True, ) <$> (mkRead <$> validAddr <*> genDefinedBitVector) - , (True, ) <$> (mkWrite <$> validAddr <*> genDefinedBitVector <*> genA) - , (False,) <$> (mkRead <$> invalidAddr <*> genDefinedBitVector) - , (False,) <$> (mkWrite <$> invalidAddr <*> genDefinedBitVector <*> genA) - ] - + Gen.choice + [ (True,) <$> (mkRead <$> validAddr <*> genDefinedBitVector) + , (True,) <$> (mkWrite <$> validAddr <*> genDefinedBitVector <*> genA) + , (False,) <$> (mkRead <$> invalidAddr <*> genDefinedBitVector) + , (False,) <$> (mkWrite <$> invalidAddr <*> genDefinedBitVector <*> genA) + ] -- | Behavioral model for 'wbStorage'. wbStorageBehaviorModel :: - forall addrW bytes . - ( 1 <= addrW, KnownNat bytes) => + forall addrW bytes. + (1 <= addrW, KnownNat bytes) => (KnownNat addrW) => [Bytes bytes] -> [(Bool, WishboneMasterRequest addrW (Bytes bytes))] -> @@ -746,7 +911,6 @@ wbStorageBehaviorModel initList initWbOps = case (cancelMulDiv @bytes @8) of where -- Invalid request f storedList (False, op) = (storedList, Error (wbMasterRequestToM2S op)) - -- Successful Read f storedList (True, op@(Read i _)) = (storedList, ReadSuccess wbM2S wbS2M) where @@ -764,39 +928,46 @@ wbStorageBehaviorModel initList initWbOps = case (cancelMulDiv @bytes @8) of newList = preEntry <> (pack newEntry : L.tail postEntry) newEntry :: Vec bytes Byte - newEntry = zipWith3 (\ b old new -> if b then new else old) - (unpack bs) (unpack oldEntry) (unpack a) + newEntry = + zipWith3 + (\b old new -> if b then new else old) + (unpack bs) + (unpack oldEntry) + (unpack a) wbStorageRangeErrors :: Property wbStorageRangeErrors = property $ do nat <- forAll $ Gen.enum 1 32 case TN.someNatVal (nat - 1) of SomeNat (succSNat . snatProxy -> n) -> go n - - where - go :: forall v m . (KnownNat v, 1 <= v, Monad m) => SNat v -> PropertyT m () - go SNat = do - content <- forAll $ genNonEmptyVec @_ @v (genDefinedBitVector @32) - wcre $ wishbonePropWithModel @System + where + go :: forall v m. (KnownNat v, 1 <= v, Monad m) => SNat v -> PropertyT m () + go SNat = do + content <- forAll $ genNonEmptyVec @_ @v (genDefinedBitVector @32) + wcre + $ wishbonePropWithModel @System defExpectOptions model (wbStorage (Reloadable $ Vec content)) (genRequests (snatToNum (SNat @v))) (snatToInteger (SNat @v) * 4) - genRequests size = Gen.list (Range.linear 0 32) + genRequests size = + Gen.list + (Range.linear 0 32) (genWishboneTransfer @32 size (genDefinedBitVector @32)) - genWishboneTransfer :: - (KnownNat addressWidth, KnownNat (BitSize a)) => - Int -> -- ^ size - Gen a -> - Gen (WishboneMasterRequest addressWidth a) - genWishboneTransfer size genA = - let - validAddr = (4*) . fromIntegral <$> Gen.enum 0 (size - 1) - invalidAddr = fromIntegral <$> Gen.enum (size * 4) (size * 8) - in + genWishboneTransfer :: + (KnownNat addressWidth, KnownNat (BitSize a)) => + Int -> + -- \^ size + Gen a -> + Gen (WishboneMasterRequest addressWidth a) + genWishboneTransfer size genA = + let + validAddr = (4 *) . fromIntegral <$> Gen.enum 0 (size - 1) + invalidAddr = fromIntegral <$> Gen.enum (size * 4) (size * 8) + in Gen.choice [ Read <$> validAddr <*> pure maxBound , Write <$> validAddr <*> pure maxBound <*> genA @@ -804,84 +975,116 @@ wbStorageRangeErrors = property $ do , Write <$> invalidAddr <*> pure maxBound <*> genA ] - - model (Read addr _) s2m@WishboneS2M{..} st0 - | addr >= fromIntegral st0 && err = Right st0 - | addr >= fromIntegral st0 && not err = - Left $ "address out of range on read should error: " - <> "addr: " <> showHex addr "" <> ", size " <> showHex st0 "" - | acknowledge = Right st0 - | otherwise = - Left $ "An in-range read should be ACK'd " - <> "addr: " <> showHex addr "" <> ", size " <> showHex st0 "" - <> " - " <> show s2m - model (Write addr _ _) s2m@WishboneS2M{..} st0 - | addr >= fromIntegral st0 && err = Right st0 - | addr >= fromIntegral st0 && not err = - Left $ "address out of range on write should error: " - <> "addr: " <> showHex addr "" <> ", size " <> showHex st0 "" - | acknowledge = Right st0 - | otherwise = - Left $ "An in-range write should be ACK'd " - <> "addr: " <> showHex addr "" <> ", size " <> showHex st0 "" - <> " - " <> show s2m + model (Read addr _) s2m@WishboneS2M{..} st0 + | addr >= fromIntegral st0 && err = Right st0 + | addr >= fromIntegral st0 && not err = + Left + $ "address out of range on read should error: " + <> "addr: " + <> showHex addr "" + <> ", size " + <> showHex st0 "" + | acknowledge = Right st0 + | otherwise = + Left + $ "An in-range read should be ACK'd " + <> "addr: " + <> showHex addr "" + <> ", size " + <> showHex st0 "" + <> " - " + <> show s2m + model (Write addr _ _) s2m@WishboneS2M{..} st0 + | addr >= fromIntegral st0 && err = Right st0 + | addr >= fromIntegral st0 && not err = + Left + $ "address out of range on write should error: " + <> "addr: " + <> showHex addr "" + <> ", size " + <> showHex st0 "" + | acknowledge = Right st0 + | otherwise = + Left + $ "An in-range write should be ACK'd " + <> "addr: " + <> showHex addr "" + <> ", size " + <> showHex st0 "" + <> " - " + <> show s2m wbStorageProtocolsModel :: Property wbStorageProtocolsModel = property $ do nat <- forAll $ Gen.enum 1 32 case TN.someNatVal (nat - 1) of SomeNat (succSNat . snatProxy -> n) -> go n - - where - go :: forall v m . (KnownNat v, 1 <= v, Monad m) => SNat v -> PropertyT m () - go SNat = do - content <- forAll $ genNonEmptyVec @_ @v (genDefinedBitVector @32) - wcre $ wishbonePropWithModel @System + where + go :: forall v m. (KnownNat v, 1 <= v, Monad m) => SNat v -> PropertyT m () + go SNat = do + content <- forAll $ genNonEmptyVec @_ @v (genDefinedBitVector @32) + wcre + $ wishbonePropWithModel @System defExpectOptions model (wbStorage (Reloadable $ Vec content)) (genRequests (snatToNum (SNat @v))) - (I.fromAscList $ L.zip [0..] (toList content)) + (I.fromAscList $ L.zip [0 ..] (toList content)) - genRequests size = Gen.list (Range.linear 0 32) + genRequests size = + Gen.list + (Range.linear 0 32) (genWishboneTransfer @32 size (genDefinedBitVector @32)) - genWishboneTransfer :: - (KnownNat addressWidth, KnownNat (BitSize a)) => - Int -> -- ^ size - Gen a -> - Gen (WishboneMasterRequest addressWidth a) - genWishboneTransfer size genA = - let - validAddr = (4*) . fromIntegral <$> Gen.enum 0 (size - 1) - in + genWishboneTransfer :: + (KnownNat addressWidth, KnownNat (BitSize a)) => + Int -> + -- \^ size + Gen a -> + Gen (WishboneMasterRequest addressWidth a) + genWishboneTransfer size genA = + let + validAddr = (4 *) . fromIntegral <$> Gen.enum 0 (size - 1) + in -- only generating _valid_ requests here Gen.choice [ Read <$> validAddr <*> pure maxBound , Write <$> validAddr <*> pure maxBound <*> genA ] - model (Read addr _) s2m@WishboneS2M{..} st0 - | err || retry = - Left $ "An in-range read should be ACK'd " - <> "addr: " <> showHex addr "" <> ", size " <> showHex (I.size st0 * 4) "" - <> " - " <> show s2m - | otherwise = - let val = st0 I.! modelAddr in - if val == readData then - Right st0 - else - Left $ "Read from model results in different value. Model: " - <> showHex val "" <> ", Circuit: " <> showHex readData "" - where - modelAddr = fromIntegral $ addr `div` 4 - - model (Write addr _ wr) s2m@WishboneS2M{..} st0 - | err || retry = - Left $ "An in-range write should be ACK'd " - <> "addr: " <> showHex addr "" <> ", size " <> showHex (I.size st0 * 4) "" - <> " - " <> show s2m - | otherwise = + model (Read addr _) s2m@WishboneS2M{..} st0 + | err || retry = + Left + $ "An in-range read should be ACK'd " + <> "addr: " + <> showHex addr "" + <> ", size " + <> showHex (I.size st0 * 4) "" + <> " - " + <> show s2m + | otherwise = + let val = st0 I.! modelAddr + in if val == readData + then Right st0 + else + Left + $ "Read from model results in different value. Model: " + <> showHex val "" + <> ", Circuit: " + <> showHex readData "" + where + modelAddr = fromIntegral $ addr `div` 4 + model (Write addr _ wr) s2m@WishboneS2M{..} st0 + | err || retry = + Left + $ "An in-range write should be ACK'd " + <> "addr: " + <> showHex addr "" + <> ", size " + <> showHex (I.size st0 * 4) "" + <> " - " + <> show s2m + | otherwise = Right $ I.insert modelAddr wr st0 - where - modelAddr = fromIntegral $ addr `div` 4 + where + modelAddr = fromIntegral $ addr `div` 4 diff --git a/bittide/tests/Tests/ElasticBuffer.hs b/bittide/tests/Tests/ElasticBuffer.hs index 2a80d436b..d94d50f3f 100644 --- a/bittide/tests/Tests/ElasticBuffer.hs +++ b/bittide/tests/Tests/ElasticBuffer.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,132 +12,193 @@ import Clash.Prelude import Test.Tasty import Test.Tasty.HUnit -import Bittide.ElasticBuffer import Bittide.ClockControl (RelDataCount, targetDataCount) +import Bittide.ElasticBuffer import qualified Data.List as L -createDomain vXilinxSystem{vPeriod=hzToPeriod 200e6, vName="Fast"} -createDomain vXilinxSystem{vPeriod=hzToPeriod 20e6, vName="Slow"} +createDomain vXilinxSystem{vPeriod = hzToPeriod 200e6, vName = "Fast"} +createDomain vXilinxSystem{vPeriod = hzToPeriod 20e6, vName = "Slow"} tests :: TestTree -tests = testGroup "Tests.ElasticBuffer" - [ testGroup "xilinxElasticBuffer" - [ testCase "case_xilinxElasticBufferMaxBound" case_xilinxElasticBufferMaxBound - , testCase "case_xilinxElasticBufferMinBound" case_xilinxElasticBufferMinBound - , testCase "case_xilinxElasticBufferEq" case_xilinxElasticBufferEq +tests = + testGroup + "Tests.ElasticBuffer" + [ testGroup + "xilinxElasticBuffer" + [ testCase "case_xilinxElasticBufferMaxBound" case_xilinxElasticBufferMaxBound + , testCase "case_xilinxElasticBufferMinBound" case_xilinxElasticBufferMinBound + , testCase "case_xilinxElasticBufferEq" case_xilinxElasticBufferEq + ] + , testGroup + "resettableXilinxElasticBuffer" + [ testCase "case_resettableXilinxElasticBufferEq" case_resettableXilinxElasticBufferEq + , testCase + "case_resettableXilinxElasticBufferMaxBound" + case_resettableXilinxElasticBufferMaxBound + , testCase + "case_resettableXilinxElasticBufferMinBound" + case_resettableXilinxElasticBufferMinBound + ] ] - , testGroup "resettableXilinxElasticBuffer" - [ testCase "case_resettableXilinxElasticBufferEq" case_resettableXilinxElasticBufferEq - , testCase "case_resettableXilinxElasticBufferMaxBound" case_resettableXilinxElasticBufferMaxBound - , testCase "case_resettableXilinxElasticBufferMinBound" case_resettableXilinxElasticBufferMinBound - ] - ] --- | When the xilinxElasticBuffer is written to more quickly than it is being read from, --- its data count should overflow. +{- | When the xilinxElasticBuffer is written to more quickly than it is being read from, +its data count should overflow. +-} case_xilinxElasticBufferMaxBound :: Assertion case_xilinxElasticBufferMaxBound = do let ebMode = fromList $ L.replicate 3 Fill <> L.repeat Pass wData = pure (0 :: Unsigned 8) underflows = - sampleN 256 - ((\(_, under, _, _)-> under) (xilinxElasticBuffer @6 (clockGen @Slow) (clockGen @Fast) resetGen ebMode wData)) + sampleN + 256 + ( (\(_, under, _, _) -> under) + (xilinxElasticBuffer @6 (clockGen @Slow) (clockGen @Fast) resetGen ebMode wData) + ) overflows = - sampleN 256 - ((\(_, _, over, _) -> over) (xilinxElasticBuffer @6 (clockGen @Slow) (clockGen @Fast) resetGen ebMode wData)) + sampleN + 256 + ( (\(_, _, over, _) -> over) + (xilinxElasticBuffer @6 (clockGen @Slow) (clockGen @Fast) resetGen ebMode wData) + ) assertBool "elastic buffer should overflow" (or overflows) assertBool "elastic buffer should not underflow" (not $ or underflows) --- | When the xilinxElasticBuffer is read from more quickly than it is being written to, --- its data count should underflow. +{- | When the xilinxElasticBuffer is read from more quickly than it is being written to, +its data count should underflow. +-} case_xilinxElasticBufferMinBound :: Assertion case_xilinxElasticBufferMinBound = do let ebMode = fromList $ L.replicate 32 Fill <> L.repeat Pass wData = pure (0 :: Unsigned 8) underflows = - sampleN 256 - ((\(_, under, _, _)-> under) (xilinxElasticBuffer @6 (clockGen @Fast) (clockGen @Slow) resetGen ebMode wData)) + sampleN + 256 + ( (\(_, under, _, _) -> under) + (xilinxElasticBuffer @6 (clockGen @Fast) (clockGen @Slow) resetGen ebMode wData) + ) overflows = - sampleN 256 - ((\(_, _, over, _)-> over) (xilinxElasticBuffer @6 (clockGen @Fast) (clockGen @Slow) resetGen ebMode wData)) + sampleN + 256 + ( (\(_, _, over, _) -> over) + (xilinxElasticBuffer @6 (clockGen @Fast) (clockGen @Slow) resetGen ebMode wData) + ) assertBool "elastic buffer should underflow" (or underflows) assertBool "elastic buffer should not overflow" (not $ or overflows) --- | When the xilinxElasticBuffer is written to as quickly to as it is read from, it should --- neither overflow nor underflow. +{- | When the xilinxElasticBuffer is written to as quickly to as it is read from, it should +neither overflow nor underflow. +-} case_xilinxElasticBufferEq :: Assertion case_xilinxElasticBufferEq = do let ebMode = fromList $ L.replicate 32 Fill <> L.repeat Pass wData = pure (0 :: Unsigned 8) underflows = - sampleN 256 - ((\(_, under, _, _)-> under) (xilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Slow) resetGen ebMode wData)) + sampleN + 256 + ( (\(_, under, _, _) -> under) + (xilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Slow) resetGen ebMode wData) + ) overflows = - sampleN 256 - ((\(_, _, over, _)-> over) (xilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Slow) resetGen ebMode wData)) + sampleN + 256 + ( (\(_, _, over, _) -> over) + (xilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Slow) resetGen ebMode wData) + ) assertBool "elastic buffer should not underflow" (not $ or underflows) assertBool "elastic buffer should not overflow" (not $ or overflows) --- | When the resettableXilinxElasticBuffer is written to as quickly as it is read from, it eventually --- stabalises. +{- | When the resettableXilinxElasticBuffer is written to as quickly as it is read from, it eventually + stabalises. +-} case_resettableXilinxElasticBufferEq :: Assertion case_resettableXilinxElasticBufferEq = do let wData = pure (0 :: Unsigned 8) - (dataCounts, underflows, overflows, ebModes, _) = L.unzip5 . - L.dropWhile (\(_, _, _, eb, _)-> eb == Drain || eb == Fill) $ sampleN 256 - (bundle (resettableXilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Slow) resetGen wData)) - dataCountBounds = L.all ((< 3) . abs . subtract (toInteger (targetDataCount :: RelDataCount 5)) . toInteger) dataCounts - - assertBool "elastic buffer should get out of its Fill state" ((>0) $ L.length ebModes) + (dataCounts, underflows, overflows, ebModes, _) = + L.unzip5 + . L.dropWhile (\(_, _, _, eb, _) -> eb == Drain || eb == Fill) + $ sampleN + 256 + ( bundle (resettableXilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Slow) resetGen wData) + ) + dataCountBounds = + L.all + ((< 3) . abs . subtract (toInteger (targetDataCount :: RelDataCount 5)) . toInteger) + dataCounts + + assertBool "elastic buffer should get out of its Fill state" ((> 0) $ L.length ebModes) assertBool "elastic buffer should not overflow after stabalising" (not $ or overflows) assertBool "elastic buffer should not underflow after stabalising" (not $ or underflows) - assertBool "elastic buffer should be in Pass mode after stabalising" (L.all (== Pass) ebModes) - assertBool "elastic buffer datacount should be `targetDataCount` (margin 3 elements) after stabalising" dataCountBounds - - --- | When the xilinxElasticBuffer is written to more quickly than it is being read from, --- its data count should overflow. Upon an overflow, the fifo is Drained and then filled --- to half full, after which the cycle repeats. + assertBool + "elastic buffer should be in Pass mode after stabalising" + (L.all (== Pass) ebModes) + assertBool + "elastic buffer datacount should be `targetDataCount` (margin 3 elements) after stabalising" + dataCountBounds + +{- | When the xilinxElasticBuffer is written to more quickly than it is being read from, +its data count should overflow. Upon an overflow, the fifo is Drained and then filled +to half full, after which the cycle repeats. +-} case_resettableXilinxElasticBufferMaxBound :: Assertion case_resettableXilinxElasticBufferMaxBound = do let wData = pure (0 :: Unsigned 8) - (_, underflows, overflows, _, _) = L.unzip5 . - L.filter (\(_, _, _, eb, _)-> eb == Pass) $ sampleN 256 - (bundle (resettableXilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Fast) resetGen wData)) + (_, underflows, overflows, _, _) = + L.unzip5 + . L.filter (\(_, _, _, eb, _) -> eb == Pass) + $ sampleN + 256 + ( bundle (resettableXilinxElasticBuffer @5 (clockGen @Slow) (clockGen @Fast) resetGen wData) + ) -- After the fifo overflows, it should Drain the buffer, then fill it to half full and -- reset. - assertBool "elastic buffer should reset after an overflow" ([True,False] `L.isInfixOf` overflows) + assertBool + "elastic buffer should reset after an overflow" + ([True, False] `L.isInfixOf` overflows) -- Since the overflows list is filtered on eb==Pass, the Drain and Fill operations are -- left out. Therefore, the fifo should not return the overflow signal twice in a row. - assertBool "elastic buffer should not overflow twice in a row" (not $ L.isInfixOf [True,True] overflows) - assertBool "elastic buffer should not underflow when written to faster than read from" (not $ or underflows) - - --- | When the xilinxElasticBuffer is read from more quickly than it is being written to, --- its data count should overflow. Upon an overflow, the fifo is Drained and then filled --- to half full, after which the cycle repeats. + assertBool + "elastic buffer should not overflow twice in a row" + (not $ L.isInfixOf [True, True] overflows) + assertBool + "elastic buffer should not underflow when written to faster than read from" + (not $ or underflows) + +{- | When the xilinxElasticBuffer is read from more quickly than it is being written to, +its data count should overflow. Upon an overflow, the fifo is Drained and then filled +to half full, after which the cycle repeats. +-} case_resettableXilinxElasticBufferMinBound :: Assertion case_resettableXilinxElasticBufferMinBound = do let wData = pure (0 :: Unsigned 8) - (_, underflows, overflows, _, _) = L.unzip5 . - L.filter (\(_, _, _, eb, _)-> eb == Pass) $ sampleN 512 - (bundle (resettableXilinxElasticBuffer @5 (clockGen @Fast) (clockGen @Slow) resetGen wData)) + (_, underflows, overflows, _, _) = + L.unzip5 + . L.filter (\(_, _, _, eb, _) -> eb == Pass) + $ sampleN + 512 + ( bundle (resettableXilinxElasticBuffer @5 (clockGen @Fast) (clockGen @Slow) resetGen wData) + ) -- After the fifo underflows, it should Drain for 1 cycle and then fill it to half -- full and reset. - assertBool "elastic buffer should reset after an underflow" ([True,False] `L.isInfixOf` underflows) + assertBool + "elastic buffer should reset after an underflow" + ([True, False] `L.isInfixOf` underflows) -- Since the underflows list is filtered on eb==Pass, the Drain and Fill operations are -- left out. Therefore, the fifo should not return the underflow signal twice in a row. - assertBool "elastic buffer should not underflow twice in a row" (not $ L.isInfixOf [True,True] underflows) - assertBool "elastic buffer should not overflow when read from faster than written to" (not $ or overflows) + assertBool + "elastic buffer should not underflow twice in a row" + (not $ L.isInfixOf [True, True] underflows) + assertBool + "elastic buffer should not overflow when read from faster than written to" + (not $ or overflows) diff --git a/bittide/tests/Tests/Haxioms.hs b/bittide/tests/Tests/Haxioms.hs index caf7ce087..8838c0243 100644 --- a/bittide/tests/Tests/Haxioms.hs +++ b/bittide/tests/Tests/Haxioms.hs @@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE NumericUnderscores #-} + module Tests.Haxioms where import Clash.Prelude @@ -19,6 +20,8 @@ prop_leMult = property $ do assert (1 <= a * b) tests :: TestTree -tests = testGroup "Haxioms" - [ testProperty "prop_leMult" prop_leMult - ] +tests = + testGroup + "Haxioms" + [ testProperty "prop_leMult" prop_leMult + ] diff --git a/bittide/tests/Tests/Link.hs b/bittide/tests/Tests/Link.hs index 1a03f663d..d0b6be056 100644 --- a/bittide/tests/Tests/Link.hs +++ b/bittide/tests/Tests/Link.hs @@ -1,13 +1,12 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 -{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} - {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} module Tests.Link where @@ -15,35 +14,43 @@ import Clash.Prelude hiding (fromList) import Clash.Hedgehog.Sized.Unsigned import Clash.Sized.Vector -import Data.Constraint (Dict(Dict)) +import Data.Constraint (Dict (Dict)) import Data.Constraint.Nat.Extra (divWithRemainder) import Data.Maybe import Data.String import GHC.Stack import Hedgehog import Hedgehog.Range as Range +import Protocols.Wishbone import Test.Tasty import Test.Tasty.Hedgehog import Tests.Shared -import Protocols.Wishbone import Bittide.Link import Bittide.SharedTypes +import Data.Bifunctor import qualified Data.List as L import qualified GHC.TypeNats as TN import qualified Hedgehog.Gen as Gen hiding (resize) -import Data.Bifunctor - tests :: TestTree -tests = testGroup "Tests.Link" - [ testPropertyNamed "txUnit can be set to continuously transmit the preamble and sequence counter." - "txSendSC" txSendSC - , testPropertyNamed "rxUnit can be set to continuously detect the preamble and store the sequence counter." - "rxSendSC" rxSendSC - , testPropertyNamed "Integration test with txUnit sending a preamble and sequence counter to rxUnit." - "integration" integration] +tests = + testGroup + "Tests.Link" + [ testPropertyNamed + "txUnit can be set to continuously transmit the preamble and sequence counter." + "txSendSC" + txSendSC + , testPropertyNamed + "rxUnit can be set to continuously detect the preamble and store the sequence counter." + "rxSendSC" + rxSendSC + , testPropertyNamed + "Integration test with txUnit sending a preamble and sequence counter to rxUnit." + "integration" + integration + ] -- | Configuration for either a txUnit or tyUnit. data TestConfig where @@ -52,13 +59,15 @@ data TestConfig where , 2 <= addressWidth , 1 <= preambleWidth , 1 <= frameWidth - , 1 <= seqCountWidth) => + , 1 <= seqCountWidth + ) => SNat bytes -> SNat addressWidth -> SNat preambleWidth -> SNat frameWidth -> SNat seqCountWidth -> TestConfig + deriving instance Show TestConfig -- | Generates a 'TestConfig' for a txUnit or tyUnit. @@ -69,246 +78,303 @@ genTestConfig = do (TN.someNatVal -> (SomeNat (snatProxy -> pw))) <- Gen.enum 8 64 (TN.someNatVal -> (SomeNat (snatProxy -> fw))) <- Gen.enum 1 64 (TN.someNatVal -> (SomeNat (snatProxy -> scw))) <- Gen.enum 4 64 - case - ( compareSNat d1 bs - , compareSNat d2 aw - , compareSNat d1 pw - , compareSNat d1 fw - , compareSNat d1 scw) of - (SNatLE, SNatLE, SNatLE, SNatLE, SNatLE) -> pure $ TestConfig bs aw pw fw scw - _ -> error "genTestConfig: Generated configuration does not satisfy constraints." + case ( compareSNat d1 bs + , compareSNat d2 aw + , compareSNat d1 pw + , compareSNat d1 fw + , compareSNat d1 scw + ) of + (SNatLE, SNatLE, SNatLE, SNatLE, SNatLE) -> pure $ TestConfig bs aw pw fw scw + _ -> error "genTestConfig: Generated configuration does not satisfy constraints." -- | Use SNat values obtained from a 'TestConfig' to configure a 'txUnit'. configTxUnit :: - forall bs aw pw fw scw . - ( HiddenClockResetEnable System, 1 <= bs, 2 <= aw, 1 <= pw, 1 <= fw, 1 <= scw) => - SNat bs -> SNat aw -> SNat pw -> SNat fw -> SNat scw -> - (BitVector pw - -> Signal System (Unsigned scw) - -> Signal System (DataLink fw) - -> Signal System (WishboneM2S aw bs (Bytes bs)) - -> (Signal System (WishboneS2M (Bytes bs)), Signal System (DataLink fw))) + forall bs aw pw fw scw. + (HiddenClockResetEnable System, 1 <= bs, 2 <= aw, 1 <= pw, 1 <= fw, 1 <= scw) => + SNat bs -> + SNat aw -> + SNat pw -> + SNat fw -> + SNat scw -> + ( BitVector pw -> + Signal System (Unsigned scw) -> + Signal System (DataLink fw) -> + Signal System (WishboneM2S aw bs (Bytes bs)) -> + (Signal System (WishboneS2M (Bytes bs)), Signal System (DataLink fw)) + ) configTxUnit SNat SNat SNat SNat SNat preamble sq frameIn m2s0 = (s2m1, dl) where (s2m0, dl) = txUnit @System @bs @aw @pw @fw @scw preamble sq frameIn m2s1 (m2s1, s2m1) = validateWb m2s0 s2m0 - -- | Use SNat values obtained from a 'TestConfig' to configure a 'rxUnit'. configRxUnit :: - forall bs aw pw fw scw . - ( HiddenClockResetEnable System, 1 <= bs, 2 <= aw, 1 <= pw, 1 <= fw, 1 <= scw) => - SNat bs -> SNat aw -> SNat pw -> SNat fw -> SNat scw -> - ( BitVector pw - -> Signal System (Unsigned scw) - -> Signal System (DataLink fw) - -> Signal System (WishboneM2S aw bs (Bytes bs)) - -> Signal System (WishboneS2M (Bytes bs))) + forall bs aw pw fw scw. + (HiddenClockResetEnable System, 1 <= bs, 2 <= aw, 1 <= pw, 1 <= fw, 1 <= scw) => + SNat bs -> + SNat aw -> + SNat pw -> + SNat fw -> + SNat scw -> + ( BitVector pw -> + Signal System (Unsigned scw) -> + Signal System (DataLink fw) -> + Signal System (WishboneM2S aw bs (Bytes bs)) -> + Signal System (WishboneS2M (Bytes bs)) + ) configRxUnit SNat SNat SNat SNat SNat linkIn preamble localCounter m2s0 = s2m1 where s2m0 = rxUnit @System @bs @aw @pw @fw @scw linkIn preamble localCounter m2s1 (m2s1, s2m1) = validateWb m2s0 s2m0 --- | Tests whether the transmission of a static preamble and static seqCounter works. --- It does so by simulating the 'txUnit' for a number of cycles in transparent mode, --- then simulating it in transmission mode, then again in transparent mode. Transparent --- and transmission mode refer to passing through the incoming link and transmitting --- preamble + sequence counter respectively. +{- | Tests whether the transmission of a static preamble and static seqCounter works. +It does so by simulating the 'txUnit' for a number of cycles in transparent mode, +then simulating it in transmission mode, then again in transparent mode. Transparent +and transmission mode refer to passing through the incoming link and transmitting +preamble + sequence counter respectively. +-} txSendSC :: Property txSendSC = property $ do tc <- forAll genTestConfig case tc of - (TestConfig - bs@(SNat :: SNat bs) - aw@(SNat :: SNat aw) - pw@(SNat :: SNat pw) - fw@(SNat :: SNat fw) - scw@(SNat :: SNat scw)) -> do - iterations <- forAll $ Gen.enum 1 10 - preamble <- forAll (genDefinedBitVector @pw) - let - pwNum = snatToNum pw - fwNum = snatToNum fw - scwNum = snatToNum scw - pwNrOfFrames = pwNum `divRU` fwNum - scNumOfFrames = scwNum `divRU` fwNum - iterationDuration = pwNrOfFrames + scNumOfFrames - iterationsTotal = iterations * iterationDuration - -- First two cycles output depend on the initial state. - -- The txUnit's state machine starts after the control register has been updated, - -- causing an extra cycle of delay. - offTime0 <- forAll $ Gen.enum 2 $ max 2 iterationsTotal - onTime <- forAll $ Gen.enum 1 iterationsTotal - offTime1 <- forAll $ Gen.enum 1 iterationsTotal - let - simLength = offTime0 + onTime + offTime1 - simRange = Range.singleton simLength - genFrame = Gen.maybe genDefinedBitVector - droppedScs = offTime0 + pwNrOfFrames - 1 - framesIn <- forAll $ Gen.list simRange genFrame - seqCountIn <- forAll $ Gen.list (Range.singleton (simLength + iterationDuration)) $ genUnsigned Range.constantBounded - let - topEntity :: - Signal System - ( Unsigned scw - , WishboneM2S aw ((bs * 8) `DivRU` 8) (Bytes bs) - , Maybe (BitVector fw) - ) -> - Signal System (WishboneS2M (Bytes bs), Maybe (BitVector fw)) - topEntity (unbundle -> (scIn, wbIn0, linkIn)) = - case divWithRemainder @bs @8 @7 of - Dict -> bundle $ withClockResetEnable - clockGen resetGen enableGen configTxUnit bs aw pw fw scw preamble scIn linkIn wbIn0 - -- Compensate for the register write + state machine start delays. - wbOff0 = L.replicate (offTime0-2) emptyWishboneM2S - wbOn = startSignal : L.replicate onTime emptyWishboneM2S - wbOff1 = stopSignal : L.repeat emptyWishboneM2S - wbIn = wbOff0 <> wbOn <> wbOff1 - RegisterBank (toList . fmap Just-> preambleFrames) = getRegsBe @fw preamble - topEntityInput = L.zip3 seqCountIn wbIn framesIn - startSignal = (emptyWishboneM2S @aw @(Bytes bs)) - { addr = 0 - , writeEnable = True - , writeData = 1 - , busSelect = maxBound - , busCycle = True - , strobe = True - } - stopSignal = (emptyWishboneM2S @aw @(Bytes bs)) - { addr = 0 - , writeEnable = True - , writeData = 0 - , busSelect = maxBound - , busCycle = True - , strobe = True - } - (wbOut, simOut) = L.unzip $ simulateN simLength topEntity topEntityInput - -- It takes 1 cycle for the the control register to be updated by the wishbone bus. - (offFrames0, L.drop onTime -> offFrames1) = L.splitAt offTime0 framesIn - onFrames = L.take onTime $ preambleFrames L.++ - L.concatMap ((L.++ preambleFrames) . valToFrames) - (everyNth iterationDuration $ - L.drop (min (simLength - 1) droppedScs) seqCountIn) - expectedOutput = L.take simLength $ offFrames0 <> onFrames <> offFrames1 - footnote . fromString $ "iterationsDuration: " <> showX iterationDuration - footnote . fromString $ "droppedSCs: " <> showX droppedScs - footnote . fromString $ "simOut: " <> showX simOut - footnote . fromString $ "expected: " <> showX expectedOutput - footnote . fromString $ "onFrames: " <> showX onFrames - footnote . fromString $ "framesIn: " <> showX (L.take simLength framesIn) - footnote . fromString $ "wbOut: " <> showX wbOut - footnote . fromString $ "wbIn: " <> showX (L.take simLength wbIn) - simOut === expectedOutput + ( TestConfig + bs@(SNat :: SNat bs) + aw@(SNat :: SNat aw) + pw@(SNat :: SNat pw) + fw@(SNat :: SNat fw) + scw@(SNat :: SNat scw) + ) -> do + iterations <- forAll $ Gen.enum 1 10 + preamble <- forAll (genDefinedBitVector @pw) + let + pwNum = snatToNum pw + fwNum = snatToNum fw + scwNum = snatToNum scw + pwNrOfFrames = pwNum `divRU` fwNum + scNumOfFrames = scwNum `divRU` fwNum + iterationDuration = pwNrOfFrames + scNumOfFrames + iterationsTotal = iterations * iterationDuration + -- First two cycles output depend on the initial state. + -- The txUnit's state machine starts after the control register has been updated, + -- causing an extra cycle of delay. + offTime0 <- forAll $ Gen.enum 2 $ max 2 iterationsTotal + onTime <- forAll $ Gen.enum 1 iterationsTotal + offTime1 <- forAll $ Gen.enum 1 iterationsTotal + let + simLength = offTime0 + onTime + offTime1 + simRange = Range.singleton simLength + genFrame = Gen.maybe genDefinedBitVector + droppedScs = offTime0 + pwNrOfFrames - 1 + framesIn <- forAll $ Gen.list simRange genFrame + seqCountIn <- + forAll + $ Gen.list (Range.singleton (simLength + iterationDuration)) + $ genUnsigned Range.constantBounded + let + topEntity :: + Signal + System + ( Unsigned scw + , WishboneM2S aw ((bs * 8) `DivRU` 8) (Bytes bs) + , Maybe (BitVector fw) + ) -> + Signal System (WishboneS2M (Bytes bs), Maybe (BitVector fw)) + topEntity (unbundle -> (scIn, wbIn0, linkIn)) = + case divWithRemainder @bs @8 @7 of + Dict -> + bundle + $ withClockResetEnable + clockGen + resetGen + enableGen + configTxUnit + bs + aw + pw + fw + scw + preamble + scIn + linkIn + wbIn0 + -- Compensate for the register write + state machine start delays. + wbOff0 = L.replicate (offTime0 - 2) emptyWishboneM2S + wbOn = startSignal : L.replicate onTime emptyWishboneM2S + wbOff1 = stopSignal : L.repeat emptyWishboneM2S + wbIn = wbOff0 <> wbOn <> wbOff1 + RegisterBank (toList . fmap Just -> preambleFrames) = getRegsBe @fw preamble + topEntityInput = L.zip3 seqCountIn wbIn framesIn + startSignal = + (emptyWishboneM2S @aw @(Bytes bs)) + { addr = 0 + , writeEnable = True + , writeData = 1 + , busSelect = maxBound + , busCycle = True + , strobe = True + } + stopSignal = + (emptyWishboneM2S @aw @(Bytes bs)) + { addr = 0 + , writeEnable = True + , writeData = 0 + , busSelect = maxBound + , busCycle = True + , strobe = True + } + (wbOut, simOut) = L.unzip $ simulateN simLength topEntity topEntityInput + -- It takes 1 cycle for the the control register to be updated by the wishbone bus. + (offFrames0, L.drop onTime -> offFrames1) = L.splitAt offTime0 framesIn + onFrames = + L.take onTime $ preambleFrames + L.++ L.concatMap + ((L.++ preambleFrames) . valToFrames) + ( everyNth iterationDuration + $ L.drop (min (simLength - 1) droppedScs) seqCountIn + ) + expectedOutput = L.take simLength $ offFrames0 <> onFrames <> offFrames1 + footnote . fromString $ "iterationsDuration: " <> showX iterationDuration + footnote . fromString $ "droppedSCs: " <> showX droppedScs + footnote . fromString $ "simOut: " <> showX simOut + footnote . fromString $ "expected: " <> showX expectedOutput + footnote . fromString $ "onFrames: " <> showX onFrames + footnote . fromString $ "framesIn: " <> showX (L.take simLength framesIn) + footnote . fromString $ "wbOut: " <> showX wbOut + footnote . fromString $ "wbIn: " <> showX (L.take simLength wbIn) + simOut === expectedOutput -- | Convert any value a to a list of frames. -valToFrames :: forall n a . (KnownNat n, 1 <= n, Paddable a) => a -> [DataLink n] +valToFrames :: forall n a. (KnownNat n, 1 <= n, Paddable a) => a -> [DataLink n] valToFrames sc = fmap Just out - where + where RegisterBank (toList -> out) = getRegsBe sc -- | Take every Nth element from a list by recursively taking the first and dropping (n-1) elements. -everyNth :: HasCallStack => Int -> [a] -> [a] +everyNth :: (HasCallStack) => Int -> [a] -> [a] everyNth 0 _ = error "Can not take every 0th element." everyNth _ [] = [] -everyNth n (x:xs) = x : everyNth n (L.drop (n-1) xs) +everyNth n (x : xs) = x : everyNth n (L.drop (n - 1) xs) --- | Tests whether the detecting of a static preamble decoding a seqCounter works. --- It does so by generating inputFrames followed by a repeated preamble and sequence --- counter and sending these to the 'rxUnit'. During transmission the 'rxUnit' is set to --- capture the sequence counter and at the end of the transmission should have the --- sequence counter available from the Wishbone bus. +{- | Tests whether the detecting of a static preamble decoding a seqCounter works. +It does so by generating inputFrames followed by a repeated preamble and sequence +counter and sending these to the 'rxUnit'. During transmission the 'rxUnit' is set to +capture the sequence counter and at the end of the transmission should have the +sequence counter available from the Wishbone bus. +-} rxSendSC :: Property rxSendSC = property $ do tc <- forAll genTestConfig case tc of - (TestConfig _ - aw@(SNat :: SNat aw) - pw@(SNat :: SNat pw) - fw@(SNat :: SNat fw) - scw@(SNat :: SNat scw)) -> do - iterations <- forAll $ Gen.enum 1 3 - preamble <- forAll $ replaceBit (natToNum @pw - 1 :: Int) 1 <$> genDefinedBitVector - let - -- We hard code the number of bytes to 4 because 'registerWB' assumes a 4 byte aligned address. - bs = d4 - (bsNum, pwNum, fwNum, scwNum) = - (snatToNum bs, snatToNum pw, snatToNum fw, snatToNum scw) - pwNrOfFrames = pwNum `divRU` fwNum - scInWords = scwNum `divRU` (bsNum * 8) - scNumOfFrames = scwNum `divRU` fwNum - iterationDuration = pwNrOfFrames + scNumOfFrames - iterationsTotal = iterations * iterationDuration - readBackCycles = 2 * scInWords - -- First two cycles output depend on the initial state. - -- The txUnit's state machine starts after the control register has been updated, - -- causing an extra cycle of delay. - offTime0 <- forAll $ Gen.enum 2 iterationsTotal - offTime1 <- forAll $ Gen.enum 2 iterationsTotal - remoteSeqCounts <- forAll . Gen.list (Range.singleton (1 + iterations)) $ - genUnsigned @_ @scw Range.constantBounded - let - onTime = iterationDuration * iterations - simLength = offTime0 + onTime + offTime1 + readBackCycles - simRange = Range.singleton simLength - RegisterBank (fmap Just . toList -> preambleFrames) = getRegsBe preamble - filterCond inp - | isJust inp = let (x,y) = (fromJust inp, fromJust $ L.head preambleFrames) in (x .&. y) /= y - | otherwise = True - genFrame = Gen.maybe genDefinedBitVector - onFrames = - L.take onTime $ L.concatMap ((preambleFrames <>) . valToFrames) remoteSeqCounts - offFrames0 <- forAll $ Gen.list (Range.singleton offTime0) $ Gen.filter filterCond genFrame - offFrames1 <- forAll $ Gen.list (Range.singleton offTime1) genFrame - localSeqCounts <- forAll . Gen.list simRange $ genUnsigned Range.constantBounded - let - topEntity (unbundle -> (wbIn0, linkIn, localCounter)) = wcre - configRxUnit bs aw pw fw scw preamble localCounter linkIn wbIn0 - -- At the end of the simulation, read the sequence counters. - wbIn = L.take (simLength - readBackCycles) (wbWrite : L.repeat (wbRead 0)) <> - fmap wbRead [1..] - framesIn = offFrames0 <> onFrames <> offFrames1 <> L.repeat Nothing - topEntityInput = L.zip3 wbIn framesIn localSeqCounts - wbWrite = (emptyWishboneM2S @aw @(Bytes 4)) - { addr = 0 :: BitVector aw - , writeEnable = True - , writeData = 1 :: BitVector 32 - , busSelect = maxBound - , busCycle = True - , strobe = True - } - wbRead (a :: BitVector aw) = (emptyWishboneM2S @aw) - { addr = shiftL a 2 - , busCycle = True - , strobe = True - , busSelect = maxBound - } - simOut = simulateN simLength topEntity topEntityInput - decodedOutput = bimap - (getDataBe @32 @(Unsigned scw)) - (getDataBe @32 @(Unsigned scw)) - <$> directedDecoding wbIn simOut - storedOutput = L.last decodedOutput - expected = (L.head remoteSeqCounts, localSeqCounts L.!! (offTime0 + pwNrOfFrames)) - -- It takes 1 cycle for the the control register to be updated by the wishbone bus. - footnote . fromString $ "wishbone reads per result: " <> show readBackCycles - footnote . fromString $ "iterationsDuration: " <> showX iterationDuration - footnote . fromString $ "simOut: " <> showX simOut - footnote . fromString $ "decodedOut: " <> showX decodedOutput - footnote . fromString $ "expected: " <> showX expected - footnote . fromString $ "onFrames: " <> showX onFrames - footnote . fromString $ "framesIn: " <> showX (L.take simLength framesIn) - footnote . fromString $ "wbIn: " <> showX (L.take simLength wbIn) - storedOutput === expected + ( TestConfig + _ + aw@(SNat :: SNat aw) + pw@(SNat :: SNat pw) + fw@(SNat :: SNat fw) + scw@(SNat :: SNat scw) + ) -> do + iterations <- forAll $ Gen.enum 1 3 + preamble <- forAll $ replaceBit (natToNum @pw - 1 :: Int) 1 <$> genDefinedBitVector + let + -- We hard code the number of bytes to 4 because 'registerWB' assumes a 4 byte aligned address. + bs = d4 + (bsNum, pwNum, fwNum, scwNum) = + (snatToNum bs, snatToNum pw, snatToNum fw, snatToNum scw) + pwNrOfFrames = pwNum `divRU` fwNum + scInWords = scwNum `divRU` (bsNum * 8) + scNumOfFrames = scwNum `divRU` fwNum + iterationDuration = pwNrOfFrames + scNumOfFrames + iterationsTotal = iterations * iterationDuration + readBackCycles = 2 * scInWords + -- First two cycles output depend on the initial state. + -- The txUnit's state machine starts after the control register has been updated, + -- causing an extra cycle of delay. + offTime0 <- forAll $ Gen.enum 2 iterationsTotal + offTime1 <- forAll $ Gen.enum 2 iterationsTotal + remoteSeqCounts <- + forAll + . Gen.list (Range.singleton (1 + iterations)) + $ genUnsigned @_ @scw Range.constantBounded + let + onTime = iterationDuration * iterations + simLength = offTime0 + onTime + offTime1 + readBackCycles + simRange = Range.singleton simLength + RegisterBank (fmap Just . toList -> preambleFrames) = getRegsBe preamble + filterCond inp + | isJust inp = + let (x, y) = (fromJust inp, fromJust $ L.head preambleFrames) in (x .&. y) /= y + | otherwise = True + genFrame = Gen.maybe genDefinedBitVector + onFrames = + L.take onTime $ L.concatMap ((preambleFrames <>) . valToFrames) remoteSeqCounts + offFrames0 <- + forAll $ Gen.list (Range.singleton offTime0) $ Gen.filter filterCond genFrame + offFrames1 <- forAll $ Gen.list (Range.singleton offTime1) genFrame + localSeqCounts <- forAll . Gen.list simRange $ genUnsigned Range.constantBounded + let + topEntity (unbundle -> (wbIn0, linkIn, localCounter)) = + wcre + configRxUnit + bs + aw + pw + fw + scw + preamble + localCounter + linkIn + wbIn0 + -- At the end of the simulation, read the sequence counters. + wbIn = + L.take (simLength - readBackCycles) (wbWrite : L.repeat (wbRead 0)) + <> fmap wbRead [1 ..] + framesIn = offFrames0 <> onFrames <> offFrames1 <> L.repeat Nothing + topEntityInput = L.zip3 wbIn framesIn localSeqCounts + wbWrite = + (emptyWishboneM2S @aw @(Bytes 4)) + { addr = 0 :: BitVector aw + , writeEnable = True + , writeData = 1 :: BitVector 32 + , busSelect = maxBound + , busCycle = True + , strobe = True + } + wbRead (a :: BitVector aw) = + (emptyWishboneM2S @aw) + { addr = shiftL a 2 + , busCycle = True + , strobe = True + , busSelect = maxBound + } + simOut = simulateN simLength topEntity topEntityInput + decodedOutput = + bimap + (getDataBe @32 @(Unsigned scw)) + (getDataBe @32 @(Unsigned scw)) + <$> directedDecoding wbIn simOut + storedOutput = L.last decodedOutput + expected = (L.head remoteSeqCounts, localSeqCounts L.!! (offTime0 + pwNrOfFrames)) + -- It takes 1 cycle for the the control register to be updated by the wishbone bus. + footnote . fromString $ "wishbone reads per result: " <> show readBackCycles + footnote . fromString $ "iterationsDuration: " <> showX iterationDuration + footnote . fromString $ "simOut: " <> showX simOut + footnote . fromString $ "decodedOut: " <> showX decodedOutput + footnote . fromString $ "expected: " <> showX expected + footnote . fromString $ "onFrames: " <> showX onFrames + footnote . fromString $ "framesIn: " <> showX (L.take simLength framesIn) + footnote . fromString $ "wbIn: " <> showX (L.take simLength wbIn) + storedOutput === expected where directedDecoding :: - forall bs aw a . + forall bs aw a. (KnownNat bs, 1 <= bs, KnownNat aw, Paddable a) => - [WishboneM2S aw bs (Bytes bs)] -> [WishboneS2M (Bytes bs)] -> [a] - directedDecoding (m2s:m2ss) (s2m:s2ms) + [WishboneM2S aw bs (Bytes bs)] -> + [WishboneS2M (Bytes bs)] -> + [a] + directedDecoding (m2s : m2ss) (s2m : s2ms) | slvAck && firstFrame && storedSC && isJust decodingData = - decoded : uncurry directedDecoding rest + decoded : uncurry directedDecoding rest | otherwise = directedDecoding m2ss s2ms where slvAck = acknowledge s2m @@ -316,123 +382,141 @@ rxSendSC = property $ do storedSC = readData s2m == resize (pack Done) bothLists = L.zip m2ss s2ms (fmap snd -> decodingFrames, L.unzip -> rest) = - span (\(m,s) -> acknowledge s && (/= 0) (addr m)) bothLists + span (\(m, s) -> acknowledge s && (/= 0) (addr m)) bothLists decodingData = fromList . fmap readData $ decodingFrames decoded = getDataLe . RegisterBank $ fromJust decodingData directedDecoding _ _ = [] --- | Tests whether we can use 'txUnit' to transmit the local sequence counter over a link with --- variable latency and capture it with 'rxUnit'. The captured timing oracle will shows us --- the latency of the link. +{- | Tests whether we can use 'txUnit' to transmit the local sequence counter over a link with +variable latency and capture it with 'rxUnit'. The captured timing oracle will shows us +the latency of the link. +-} integration :: Property integration = property $ do tc <- forAll genTestConfig linkLatency <- forAll $ Gen.int (Range.constant 0 64) case (TN.someNatVal (fromIntegral linkLatency), tc) of - (SomeNat llProxy, - TestConfig _ - aw@(SNat :: SNat aw) - pw@(SNat :: SNat pw) - fw@(SNat :: SNat fw) - scw@(SNat :: SNat scw)) -> do - iterations <- forAll $ Gen.enum 1 3 - preamble <- forAll $ replaceBit (natToNum @pw - 1:: Integer ) 1 <$> genDefinedBitVector - let - -- We hard code the number of bytes to 4 because 'registerWB' assumes a 4 byte aligned address. - bs = d4 - bsNum = snatToNum bs - pwNum = snatToNum pw - fwNum = snatToNum fw - scwNum = snatToNum scw - pwNrOfFrames = pwNum `divRU` fwNum - scNumOfFrames = scwNum `divRU` fwNum - iterationDuration = pwNrOfFrames + scNumOfFrames - iterationsTotal = iterations * iterationDuration - scInWords = scwNum `divRU` (bsNum * 8) - readBackCycles = 2 * scInWords + ( SomeNat llProxy + , TestConfig + _ + aw@(SNat :: SNat aw) + pw@(SNat :: SNat pw) + fw@(SNat :: SNat fw) + scw@(SNat :: SNat scw) + ) -> do + iterations <- forAll $ Gen.enum 1 3 + preamble <- forAll $ replaceBit (natToNum @pw - 1 :: Integer) 1 <$> genDefinedBitVector + let + -- We hard code the number of bytes to 4 because 'registerWB' assumes a 4 byte aligned address. + bs = d4 + bsNum = snatToNum bs + pwNum = snatToNum pw + fwNum = snatToNum fw + scwNum = snatToNum scw + pwNrOfFrames = pwNum `divRU` fwNum + scNumOfFrames = scwNum `divRU` fwNum + iterationDuration = pwNrOfFrames + scNumOfFrames + iterationsTotal = iterations * iterationDuration + scInWords = scwNum `divRU` (bsNum * 8) + readBackCycles = 2 * scInWords - -- First two cycles output depend on the initial state. - -- The txUnit's state machine starts after the control register has been updated, - -- causing an extra cycle of delay. - delayCycles <- forAll $ Gen.enum 2 (2 + iterationsTotal) - transmitCycles <- forAll $ Gen.enum iterationDuration iterationsTotal - postTransmitCycles <- forAll $ Gen.enum - -- We need at most 2 read back cycles to reliably read the captured counters. - -- Each read attempt requires an extra cycle to read the control register. - (linkLatency + 2 * ( 1 + readBackCycles)) - (linkLatency + 2 * ( 1 + readBackCycles) + iterationsTotal) - let - RegisterBank (fmap Just . toList -> preambleFrames) = getRegsBe preamble - simLength = delayCycles + transmitCycles + postTransmitCycles - filterCond inp - | isJust inp = let (x,y) = (fromJust inp, fromJust $ L.head preambleFrames) in (x .&. y) /= y - | otherwise = True - genFrame = Gen.maybe genDefinedBitVector - gatherFrames0 <- forAll . Gen.list (Range.singleton delayCycles) $ Gen.filter filterCond genFrame - gatherFrames1 <- forAll $ Gen.list (Range.singleton (simLength - delayCycles)) genFrame - let - topEntity :: HiddenClockResetEnable System => - ( Signal System (Maybe (BitVector fw) - , Unsigned scw - , WishboneM2S aw 4 (Bytes 4) - , WishboneM2S aw 4 (Bytes 4)) - -> Signal System (DataLink fw, WishboneS2M (Bytes 4))) - topEntity (unbundle -> (gatherOut, counter, wbTxM2S, wbRxM2S)) = out - where - (_, linkIn) = configTxUnit bs aw pw fw scw preamble counter gatherOut wbTxM2S - linkOut = registerN (snatProxy llProxy) Nothing linkIn - wbRxS2M = configRxUnit bs aw pw fw scw preamble counter linkOut wbRxM2S - out = bundle (linkIn, wbRxS2M) - -- Compensate for the register write + state machine start delays. - wbTxOff = L.replicate (delayCycles - 2) emptyWishboneM2S - wbTxOn = wbWrite 0 1 : L.replicate transmitCycles emptyWishboneM2S - wbTxIn = wbTxOff <> wbTxOn <> (wbWrite 0 0 : L.repeat emptyWishboneM2S) - wbRxRead0 = L.replicate (delayCycles + transmitCycles - 1) (wbRead 0) - wbRxIn = wbWrite 0 1 : wbRxRead0 <> cycle (fmap wbRead [0..fromIntegral readBackCycles]) - counters = cycle [0..] - framesIn = gatherFrames0 <> gatherFrames1 <> L.repeat Nothing - topEntityInput = L.zip4 framesIn counters wbTxIn wbRxIn - wbWrite a x = (emptyWishboneM2S @aw @(Bytes 4)) - { addr = shiftL a 2 - , writeEnable = True - , writeData =x - , busSelect = maxBound - , busCycle = True - , strobe = True - } - wbRead (a :: BitVector aw) = (emptyWishboneM2S @aw) - { addr = shiftL a 2 - , busCycle = True - , strobe = True - , busSelect = maxBound - } - (linkFrames, wbRxOut) = L.unzip $ simulateN simLength topEntity topEntityInput - decodedOutput = bimap - (getDataBe @32 @(Unsigned scw)) - (getDataBe @32 @(Unsigned scw)) - <$> directedDecoding wbRxIn wbRxOut - storedOutput = L.last decodedOutput - expected = - ( fromIntegral (delayCycles + pwNrOfFrames - 1) - , fromIntegral (delayCycles + linkLatency + pwNrOfFrames)) - -- It takes 1 cycle for the the control register to be updated by the wishbone bus. - footnote . fromString $ "readBackCycles: " <> show readBackCycles - footnote . fromString $ "iterationsDuration: " <> showX iterationDuration - footnote . fromString $ "linkFrames: " <> showX linkFrames - footnote . fromString $ "wbRxOut: " <> showX wbRxOut - footnote . fromString $ "wbRxIn: " <> showX (L.take simLength wbRxIn) - footnote . fromString $ "decodedOut: " <> showX decodedOutput - footnote . fromString $ "expected: " <> showX expected - footnote . fromString $ "framesIn: " <> showX (L.take simLength framesIn) - storedOutput === expected + -- First two cycles output depend on the initial state. + -- The txUnit's state machine starts after the control register has been updated, + -- causing an extra cycle of delay. + delayCycles <- forAll $ Gen.enum 2 (2 + iterationsTotal) + transmitCycles <- forAll $ Gen.enum iterationDuration iterationsTotal + postTransmitCycles <- + forAll + $ Gen.enum + -- We need at most 2 read back cycles to reliably read the captured counters. + -- Each read attempt requires an extra cycle to read the control register. + (linkLatency + 2 * (1 + readBackCycles)) + (linkLatency + 2 * (1 + readBackCycles) + iterationsTotal) + let + RegisterBank (fmap Just . toList -> preambleFrames) = getRegsBe preamble + simLength = delayCycles + transmitCycles + postTransmitCycles + filterCond inp + | isJust inp = + let (x, y) = (fromJust inp, fromJust $ L.head preambleFrames) in (x .&. y) /= y + | otherwise = True + genFrame = Gen.maybe genDefinedBitVector + gatherFrames0 <- + forAll . Gen.list (Range.singleton delayCycles) $ Gen.filter filterCond genFrame + gatherFrames1 <- forAll $ Gen.list (Range.singleton (simLength - delayCycles)) genFrame + let + topEntity :: + (HiddenClockResetEnable System) => + ( Signal + System + ( Maybe (BitVector fw) + , Unsigned scw + , WishboneM2S aw 4 (Bytes 4) + , WishboneM2S aw 4 (Bytes 4) + ) -> + Signal System (DataLink fw, WishboneS2M (Bytes 4)) + ) + topEntity (unbundle -> (gatherOut, counter, wbTxM2S, wbRxM2S)) = out + where + (_, linkIn) = configTxUnit bs aw pw fw scw preamble counter gatherOut wbTxM2S + linkOut = registerN (snatProxy llProxy) Nothing linkIn + wbRxS2M = configRxUnit bs aw pw fw scw preamble counter linkOut wbRxM2S + out = bundle (linkIn, wbRxS2M) + -- Compensate for the register write + state machine start delays. + wbTxOff = L.replicate (delayCycles - 2) emptyWishboneM2S + wbTxOn = wbWrite 0 1 : L.replicate transmitCycles emptyWishboneM2S + wbTxIn = wbTxOff <> wbTxOn <> (wbWrite 0 0 : L.repeat emptyWishboneM2S) + wbRxRead0 = L.replicate (delayCycles + transmitCycles - 1) (wbRead 0) + wbRxIn = wbWrite 0 1 : wbRxRead0 <> cycle (fmap wbRead [0 .. fromIntegral readBackCycles]) + counters = cycle [0 ..] + framesIn = gatherFrames0 <> gatherFrames1 <> L.repeat Nothing + topEntityInput = L.zip4 framesIn counters wbTxIn wbRxIn + wbWrite a x = + (emptyWishboneM2S @aw @(Bytes 4)) + { addr = shiftL a 2 + , writeEnable = True + , writeData = x + , busSelect = maxBound + , busCycle = True + , strobe = True + } + wbRead (a :: BitVector aw) = + (emptyWishboneM2S @aw) + { addr = shiftL a 2 + , busCycle = True + , strobe = True + , busSelect = maxBound + } + (linkFrames, wbRxOut) = L.unzip $ simulateN simLength topEntity topEntityInput + decodedOutput = + bimap + (getDataBe @32 @(Unsigned scw)) + (getDataBe @32 @(Unsigned scw)) + <$> directedDecoding wbRxIn wbRxOut + storedOutput = L.last decodedOutput + expected = + ( fromIntegral (delayCycles + pwNrOfFrames - 1) + , fromIntegral (delayCycles + linkLatency + pwNrOfFrames) + ) + -- It takes 1 cycle for the the control register to be updated by the wishbone bus. + footnote . fromString $ "readBackCycles: " <> show readBackCycles + footnote . fromString $ "iterationsDuration: " <> showX iterationDuration + footnote . fromString $ "linkFrames: " <> showX linkFrames + footnote . fromString $ "wbRxOut: " <> showX wbRxOut + footnote . fromString $ "wbRxIn: " <> showX (L.take simLength wbRxIn) + footnote . fromString $ "decodedOut: " <> showX decodedOutput + footnote . fromString $ "expected: " <> showX expected + footnote . fromString $ "framesIn: " <> showX (L.take simLength framesIn) + storedOutput === expected where directedDecoding :: - forall bs aw a . + forall bs aw a. (KnownNat bs, 1 <= bs, KnownNat aw, Paddable a) => - [WishboneM2S aw bs (Bytes bs)] -> [WishboneS2M (Bytes bs)] -> [a] - directedDecoding (m2s:m2ss) (s2m:s2ms) + [WishboneM2S aw bs (Bytes bs)] -> + [WishboneS2M (Bytes bs)] -> + [a] + directedDecoding (m2s : m2ss) (s2m : s2ms) | slvAck && firstFrame && storedSC && isJust decodingData = - decoded : uncurry directedDecoding rest + decoded : uncurry directedDecoding rest | otherwise = directedDecoding m2ss s2ms where slvAck = acknowledge s2m @@ -440,7 +524,7 @@ integration = property $ do storedSC = readData s2m == resize (pack Done) bothLists = L.zip m2ss s2ms (fmap snd -> decodingFrames, L.unzip -> rest) = - span (\(m,s) -> acknowledge s && (/= 0) (addr m)) bothLists + span (\(m, s) -> acknowledge s && (/= 0) (addr m)) bothLists decodingData = fromList $ fmap readData decodingFrames decoded = getDataLe . RegisterBank $ fromJust decodingData directedDecoding _ _ = [] @@ -448,7 +532,10 @@ integration = property $ do -- | Register with a configurable amount of stages n where (n ~ 0) results in a wire. registerN :: (HiddenClockResetEnable dom, NFDataX o, KnownNat n) => - SNat n -> o -> Signal dom o -> Signal dom o + SNat n -> + o -> + Signal dom o -> + Signal dom o registerN n a = mealy go (replicate n a) where go state0 inp = (tail z, head z) diff --git a/bittide/tests/Tests/ProcessingElement/ReadElf.hs b/bittide/tests/Tests/ProcessingElement/ReadElf.hs index be0e8d3ae..cb7cd906b 100644 --- a/bittide/tests/Tests/ProcessingElement/ReadElf.hs +++ b/bittide/tests/Tests/ProcessingElement/ReadElf.hs @@ -18,254 +18,278 @@ import qualified Data.ByteString as BS import qualified Data.List as L riscvElfEmpty :: Elf -riscvElfEmpty = Elf - { elfClass = ELFCLASS32 - , elfData = ELFDATA2LSB - , elfVersion = 1 - , elfOSABI = ELFOSABI_SYSV - , elfABIVersion = 1 - , elfType = ET_EXEC - , elfMachine = EM_EXT 0xF3 -- RISC-V - , elfEntry = 0x80000000 - , elfSections = [] - , elfSegments = [] - } +riscvElfEmpty = + Elf + { elfClass = ELFCLASS32 + , elfData = ELFDATA2LSB + , elfVersion = 1 + , elfOSABI = ELFOSABI_SYSV + , elfABIVersion = 1 + , elfType = ET_EXEC + , elfMachine = EM_EXT 0xF3 -- RISC-V + , elfEntry = 0x80000000 + , elfSections = [] + , elfSegments = [] + } textSection :: ElfSection -textSection = ElfSection - { elfSectionName = ".text" - , elfSectionType = SHT_PROGBITS - , elfSectionFlags = [SHF_ALLOC, SHF_EXECINSTR] - , elfSectionAddr = 0x80000000 - , elfSectionSize = 0 - , elfSectionLink = 0 - , elfSectionInfo = 0 - , elfSectionAddrAlign = 0x00010000 - , elfSectionEntSize = 0 - , elfSectionData = BS.empty - } +textSection = + ElfSection + { elfSectionName = ".text" + , elfSectionType = SHT_PROGBITS + , elfSectionFlags = [SHF_ALLOC, SHF_EXECINSTR] + , elfSectionAddr = 0x80000000 + , elfSectionSize = 0 + , elfSectionLink = 0 + , elfSectionInfo = 0 + , elfSectionAddrAlign = 0x00010000 + , elfSectionEntSize = 0 + , elfSectionData = BS.empty + } dataSection :: ElfSection -dataSection = ElfSection - { elfSectionName = ".data" - , elfSectionType = SHT_PROGBITS - , elfSectionFlags = [SHF_ALLOC, SHF_WRITE] - , elfSectionAddr = 0x80000000 - , elfSectionSize = 0 - , elfSectionLink = 0 - , elfSectionInfo = 0 - , elfSectionAddrAlign = 0x00010000 - , elfSectionEntSize = 0 - , elfSectionData = BS.empty - } +dataSection = + ElfSection + { elfSectionName = ".data" + , elfSectionType = SHT_PROGBITS + , elfSectionFlags = [SHF_ALLOC, SHF_WRITE] + , elfSectionAddr = 0x80000000 + , elfSectionSize = 0 + , elfSectionLink = 0 + , elfSectionInfo = 0 + , elfSectionAddrAlign = 0x00010000 + , elfSectionEntSize = 0 + , elfSectionData = BS.empty + } rodataSection :: ElfSection -rodataSection = dataSection - { elfSectionName = ".rodata" - , elfSectionFlags = [SHF_ALLOC] - } +rodataSection = + dataSection + { elfSectionName = ".rodata" + , elfSectionFlags = [SHF_ALLOC] + } bssSection :: ElfSection -bssSection = ElfSection - { elfSectionName = ".bss" - , elfSectionType = SHT_NOBITS - , elfSectionFlags = [SHF_ALLOC, SHF_WRITE] - , elfSectionAddr = 0x80000000 - , elfSectionSize = 0 - , elfSectionLink = 0 - , elfSectionInfo = 0 - , elfSectionAddrAlign = 0x00010000 - , elfSectionEntSize = 0 - , elfSectionData = BS.empty - } +bssSection = + ElfSection + { elfSectionName = ".bss" + , elfSectionType = SHT_NOBITS + , elfSectionFlags = [SHF_ALLOC, SHF_WRITE] + , elfSectionAddr = 0x80000000 + , elfSectionSize = 0 + , elfSectionLink = 0 + , elfSectionInfo = 0 + , elfSectionAddrAlign = 0x00010000 + , elfSectionEntSize = 0 + , elfSectionData = BS.empty + } instrSegment :: ElfSegment -instrSegment = ElfSegment - { elfSegmentType = PT_LOAD - , elfSegmentFlags = [PF_R, PF_X] - , elfSegmentVirtAddr = 0x80000000 - , elfSegmentPhysAddr = 0x80000000 - , elfSegmentAlign = 0x00010000 - , elfSegmentData = BS.empty - , elfSegmentMemSize = 0 - } +instrSegment = + ElfSegment + { elfSegmentType = PT_LOAD + , elfSegmentFlags = [PF_R, PF_X] + , elfSegmentVirtAddr = 0x80000000 + , elfSegmentPhysAddr = 0x80000000 + , elfSegmentAlign = 0x00010000 + , elfSegmentData = BS.empty + , elfSegmentMemSize = 0 + } dataSegment :: ElfSegment -dataSegment = ElfSegment - { elfSegmentType = PT_LOAD - , elfSegmentFlags = [PF_R, PF_W] - , elfSegmentVirtAddr = 0x80000000 - , elfSegmentPhysAddr = 0x80000000 - , elfSegmentAlign = 0x00010000 - , elfSegmentData = BS.empty - , elfSegmentMemSize = 0 - } +dataSegment = + ElfSegment + { elfSegmentType = PT_LOAD + , elfSegmentFlags = [PF_R, PF_W] + , elfSegmentVirtAddr = 0x80000000 + , elfSegmentPhysAddr = 0x80000000 + , elfSegmentAlign = 0x00010000 + , elfSegmentData = BS.empty + , elfSegmentMemSize = 0 + } tests :: TestTree -tests = testGroup "Read ELF Tests" - [ testCase "ELF file empty" $ do - let - elf = riscvElfEmpty - (entry, iMem, dMem) = readElf elf +tests = + testGroup + "Read ELF Tests" + [ testCase "ELF file empty" $ do + let + elf = riscvElfEmpty + (entry, iMem, dMem) = readElf elf - elfEntry elf @?= fromIntegral entry - iMem @?= I.fromList [] - dMem @?= I.fromList [] - - - , testCase "ELF file, only .text" $ do - let - iData = L.replicate 100 0xAB - elf = riscvElfEmpty - { elfSections = - [ textSection - { elfSectionAddr = 0x80000000 - , elfSectionSize = fromIntegral $ L.length iData - , elfSectionData = BS.pack iData - } - ] - , elfSegments = - [ instrSegment - { elfSegmentVirtAddr = 0x80000000 - , elfSegmentPhysAddr = 0x80000000 - , elfSegmentData = BS.pack iData - , elfSegmentMemSize = fromIntegral $ L.length iData - } - ] - } - (entry, iMem, dMem) = readElf elf - iDataMap = I.fromList (L.zip [0x80000000..] (fromIntegral <$> iData)) - - elfEntry elf @?= fromIntegral entry - assertEqual "instruction memory contains instruction data" iDataMap (I.intersection iMem iDataMap) - dMem @?= I.fromList [] - - , testCase "ELF file, .data and .rodata" $ do - let - data' = L.replicate 100 0xAB - roData = L.replicate 50 0x0F - elf = riscvElfEmpty - { elfSections = - [ dataSection - { elfSectionAddr = 0x80000000 - , elfSectionSize = fromIntegral $ L.length data' - , elfSectionData = BS.pack data' - } - , rodataSection - { elfSectionAddr = 0x80000000 + fromIntegral (L.length data') - , elfSectionSize = fromIntegral $ L.length roData - , elfSectionData = BS.pack roData - } - ] - , elfSegments = - [ dataSegment - { elfSegmentVirtAddr = 0x80000000 - , elfSegmentPhysAddr = 0x80000000 - , elfSegmentData = BS.pack (data' <> roData) - , elfSegmentMemSize = fromIntegral $ L.length data' + L.length roData - } - ] - } - (entry, iMem, dMem) = readElf elf - dataMap = I.fromList (L.zip [0x80000000..] (fromIntegral <$> (data' <> roData))) - - elfEntry elf @?= fromIntegral entry - iMem @?= I.fromList [] - assertEqual "instruction memory contains instruction data" dataMap (I.intersection dMem dataMap) - - , testCase "ELF file, .text and .data" $ do - let - iData = L.replicate 100 0xAB - dData = L.replicate 1000 0xB3 - elf = riscvElfEmpty - { elfSections = - [ textSection - { elfSectionAddr = 0x80000000 - , elfSectionSize = fromIntegral $ L.length iData - , elfSectionData = BS.pack iData - } - , dataSection - { elfSectionAddr = 0x80000000 + fromIntegral (L.length iData) - , elfSectionSize = fromIntegral $ L.length dData - , elfSectionData = BS.pack dData - } - ] - , elfSegments = - [ instrSegment - { elfSegmentVirtAddr = 0x80000000 - , elfSegmentPhysAddr = 0x80000000 - , elfSegmentData = BS.pack iData - , elfSegmentMemSize = fromIntegral $ L.length iData - } - , dataSegment - { elfSegmentVirtAddr = 0x80000000 + fromIntegral (L.length iData) - , elfSegmentPhysAddr = 0x80000000 + fromIntegral (L.length iData) - , elfSegmentData = BS.pack dData - , elfSegmentMemSize = fromIntegral $ L.length dData - } - ] - } - (entry, iMem, dMem) = readElf elf - iDataMap = I.fromList (L.zip [0x80000000..] (fromIntegral <$> iData)) - dDataMap = I.fromList (L.zip [(0x80000000 + fromIntegral (L.length iData))..] (fromIntegral <$> dData)) + elfEntry elf @?= fromIntegral entry + iMem @?= I.fromList [] + dMem @?= I.fromList [] + , testCase "ELF file, only .text" $ do + let + iData = L.replicate 100 0xAB + elf = + riscvElfEmpty + { elfSections = + [ textSection + { elfSectionAddr = 0x80000000 + , elfSectionSize = fromIntegral $ L.length iData + , elfSectionData = BS.pack iData + } + ] + , elfSegments = + [ instrSegment + { elfSegmentVirtAddr = 0x80000000 + , elfSegmentPhysAddr = 0x80000000 + , elfSegmentData = BS.pack iData + , elfSegmentMemSize = fromIntegral $ L.length iData + } + ] + } + (entry, iMem, dMem) = readElf elf + iDataMap = I.fromList (L.zip [0x80000000 ..] (fromIntegral <$> iData)) - elfEntry elf @?= fromIntegral entry - assertEqual "instruction memory contains instruction data" iDataMap (I.intersection iMem iDataMap) - assertEqual "data memory contains data contents" dDataMap (I.intersection dMem dDataMap) + elfEntry elf @?= fromIntegral entry + assertEqual + "instruction memory contains instruction data" + iDataMap + (I.intersection iMem iDataMap) + dMem @?= I.fromList [] + , testCase "ELF file, .data and .rodata" $ do + let + data' = L.replicate 100 0xAB + roData = L.replicate 50 0x0F + elf = + riscvElfEmpty + { elfSections = + [ dataSection + { elfSectionAddr = 0x80000000 + , elfSectionSize = fromIntegral $ L.length data' + , elfSectionData = BS.pack data' + } + , rodataSection + { elfSectionAddr = 0x80000000 + fromIntegral (L.length data') + , elfSectionSize = fromIntegral $ L.length roData + , elfSectionData = BS.pack roData + } + ] + , elfSegments = + [ dataSegment + { elfSegmentVirtAddr = 0x80000000 + , elfSegmentPhysAddr = 0x80000000 + , elfSegmentData = BS.pack (data' <> roData) + , elfSegmentMemSize = fromIntegral $ L.length data' + L.length roData + } + ] + } + (entry, iMem, dMem) = readElf elf + dataMap = I.fromList (L.zip [0x80000000 ..] (fromIntegral <$> (data' <> roData))) + elfEntry elf @?= fromIntegral entry + iMem @?= I.fromList [] + assertEqual + "instruction memory contains instruction data" + dataMap + (I.intersection dMem dataMap) + , testCase "ELF file, .text and .data" $ do + let + iData = L.replicate 100 0xAB + dData = L.replicate 1000 0xB3 + elf = + riscvElfEmpty + { elfSections = + [ textSection + { elfSectionAddr = 0x80000000 + , elfSectionSize = fromIntegral $ L.length iData + , elfSectionData = BS.pack iData + } + , dataSection + { elfSectionAddr = 0x80000000 + fromIntegral (L.length iData) + , elfSectionSize = fromIntegral $ L.length dData + , elfSectionData = BS.pack dData + } + ] + , elfSegments = + [ instrSegment + { elfSegmentVirtAddr = 0x80000000 + , elfSegmentPhysAddr = 0x80000000 + , elfSegmentData = BS.pack iData + , elfSegmentMemSize = fromIntegral $ L.length iData + } + , dataSegment + { elfSegmentVirtAddr = 0x80000000 + fromIntegral (L.length iData) + , elfSegmentPhysAddr = 0x80000000 + fromIntegral (L.length iData) + , elfSegmentData = BS.pack dData + , elfSegmentMemSize = fromIntegral $ L.length dData + } + ] + } + (entry, iMem, dMem) = readElf elf + iDataMap = I.fromList (L.zip [0x80000000 ..] (fromIntegral <$> iData)) + dDataMap = + I.fromList + (L.zip [(0x80000000 + fromIntegral (L.length iData)) ..] (fromIntegral <$> dData)) - , testCase "ELF file, .text, .data and .bss" $ do - let - iData = L.replicate 100 0xAB - dData = L.replicate 1000 0xB3 - bssLen = 500 + elfEntry elf @?= fromIntegral entry + assertEqual + "instruction memory contains instruction data" + iDataMap + (I.intersection iMem iDataMap) + assertEqual "data memory contains data contents" dDataMap (I.intersection dMem dDataMap) + , testCase "ELF file, .text, .data and .bss" $ do + let + iData = L.replicate 100 0xAB + dData = L.replicate 1000 0xB3 + bssLen = 500 - iStart = 0x80000000 - dStart = iStart + L.length iData - bssStart = dStart + L.length dData - elf = riscvElfEmpty - { elfSections = - [ textSection - { elfSectionAddr = fromIntegral iStart - , elfSectionSize = fromIntegral $ L.length iData - , elfSectionData = BS.pack iData - } - , dataSection - { elfSectionAddr = fromIntegral dStart - , elfSectionSize = fromIntegral $ L.length dData - , elfSectionData = BS.pack dData - } - , bssSection - { elfSectionAddr = fromIntegral bssStart - , elfSectionSize = bssLen - , elfSectionData = BS.empty - } - ] - , elfSegments = - [ instrSegment - { elfSegmentVirtAddr = fromIntegral iStart - , elfSegmentPhysAddr = fromIntegral iStart - , elfSegmentData = BS.pack iData - , elfSegmentMemSize = fromIntegral $ L.length iData - } - , dataSegment - { elfSegmentVirtAddr = fromIntegral dStart - , elfSegmentPhysAddr = fromIntegral dStart - , elfSegmentData = BS.pack dData - , elfSegmentMemSize = fromIntegral (L.length dData) + fromIntegral bssLen + iStart = 0x80000000 + dStart = iStart + L.length iData + bssStart = dStart + L.length dData + elf = + riscvElfEmpty + { elfSections = + [ textSection + { elfSectionAddr = fromIntegral iStart + , elfSectionSize = fromIntegral $ L.length iData + , elfSectionData = BS.pack iData + } + , dataSection + { elfSectionAddr = fromIntegral dStart + , elfSectionSize = fromIntegral $ L.length dData + , elfSectionData = BS.pack dData + } + , bssSection + { elfSectionAddr = fromIntegral bssStart + , elfSectionSize = bssLen + , elfSectionData = BS.empty + } + ] + , elfSegments = + [ instrSegment + { elfSegmentVirtAddr = fromIntegral iStart + , elfSegmentPhysAddr = fromIntegral iStart + , elfSegmentData = BS.pack iData + , elfSegmentMemSize = fromIntegral $ L.length iData + } + , dataSegment + { elfSegmentVirtAddr = fromIntegral dStart + , elfSegmentPhysAddr = fromIntegral dStart + , elfSegmentData = BS.pack dData + , elfSegmentMemSize = fromIntegral (L.length dData) + fromIntegral bssLen + } + ] } - ] - } - (entry, iMem, dMem) = readElf elf - iDataMap = I.fromList (L.zip [iStart..] (fromIntegral <$> iData)) - dDataMap = I.unionWithKey (\k _ _ -> error $ - "Tests.ContranomySim.ReadElf : Overlapping elements in `.data` and `.bss` memory at address 0x" - <> showHex k "") - (I.fromList (L.zip [dStart..] (fromIntegral <$> dData))) - (I.fromList (L.zip [bssStart..] (L.replicate (fromIntegral bssLen) 0))) - - elfEntry elf @?= fromIntegral entry - assertEqual "instruction memory contains instruction data" iDataMap (I.intersection iMem iDataMap) - assertEqual "data memory contains data contents" dDataMap (I.intersection dMem dDataMap) + (entry, iMem, dMem) = readElf elf + iDataMap = I.fromList (L.zip [iStart ..] (fromIntegral <$> iData)) + dDataMap = + I.unionWithKey + ( \k _ _ -> + error $ + "Tests.ContranomySim.ReadElf : Overlapping elements in `.data` and `.bss` memory at address 0x" + <> showHex k "" + ) + (I.fromList (L.zip [dStart ..] (fromIntegral <$> dData))) + (I.fromList (L.zip [bssStart ..] (L.replicate (fromIntegral bssLen) 0))) - ] + elfEntry elf @?= fromIntegral entry + assertEqual + "instruction memory contains instruction data" + iDataMap + (I.intersection iMem iDataMap) + assertEqual "data memory contains data contents" dDataMap (I.intersection dMem dDataMap) + ] diff --git a/bittide/tests/Tests/ScatterGather.hs b/bittide/tests/Tests/ScatterGather.hs index a3114ea43..0dce3c0e2 100644 --- a/bittide/tests/Tests/ScatterGather.hs +++ b/bittide/tests/Tests/ScatterGather.hs @@ -1,20 +1,17 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - -{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} - --- For Show (SNatLE a b) -{-# OPTIONS_GHC -Wno-orphans #-} - +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} +-- For Show (SNatLE a b) +{-# OPTIONS_GHC -Wno-orphans #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} -module Tests.ScatterGather(tests) where +module Tests.ScatterGather (tests) where import Clash.Prelude hiding (fromList) import qualified Prelude as P @@ -32,17 +29,19 @@ import Bittide.ScatterGather import Bittide.SharedTypes import Tests.Shared +import qualified Bittide.Calendar as Cal (ExtraRegs) import qualified Clash.Util.Interpolate as I import qualified GHC.TypeNats as TN import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import qualified Bittide.Calendar as Cal(ExtraRegs) --- | The extra in SomeCalendar extra defines the minimum amount of elements in the vector --- and the minimum addressable indexes in the vector elements. I.e, vectors of 0 elements --- and Index 0 as element are not allowed. +{- | The extra in SomeCalendar extra defines the minimum amount of elements in the vector +and the minimum addressable indexes in the vector elements. I.e, vectors of 0 elements +and Index 0 as element are not allowed. +-} data SomeCalendar extra where - SomeCalendar :: (1 <= (extra + n)) => SNat n -> Vec (n + extra) (Index (n + extra)) -> SomeCalendar extra + SomeCalendar :: + (1 <= (extra + n)) => SNat n -> Vec (n + extra) (Index (n + extra)) -> SomeCalendar extra instance Show (SomeCalendar extra) where show (SomeCalendar SNat list) = show list @@ -57,22 +56,34 @@ genFrameList :: Range Int -> Gen [Maybe (BitVector 64)] genFrameList range = Gen.list range genFrame tests :: TestTree -tests = testGroup "Tests.ScatterGather" - [ testPropertyNamed "scatterUnitWb - No overwriting implies no lost frames." - "scatterUnitNoFrameLoss" scatterUnitNoFrameLoss - , testPropertyNamed "gatherUnitWb - No overwriting implies no lost frames." - "gatherUnitNoFrameLoss" gatherUnitNoFrameLoss - , testPropertyNamed "S/G units - Ack stalling address at metacycle end." - "metacycleStalling" metacycleStalling - ] +tests = + testGroup + "Tests.ScatterGather" + [ testPropertyNamed + "scatterUnitWb - No overwriting implies no lost frames." + "scatterUnitNoFrameLoss" + scatterUnitNoFrameLoss + , testPropertyNamed + "gatherUnitWb - No overwriting implies no lost frames." + "gatherUnitNoFrameLoss" + gatherUnitNoFrameLoss + , testPropertyNamed + "S/G units - Ack stalling address at metacycle end." + "metacycleStalling" + metacycleStalling + ] -- | Generates a 'CalendarConfig' for the 'gatherUnitWb' or 'scatterUnitWb' genCalendarConfig :: - forall nBytes addrW calEntry maxDepth . - ( KnownNat nBytes, 1 <= nBytes - , KnownNat maxDepth, 2 <= maxDepth - , KnownNat addrW, 2 <= addrW - , calEntry ~ Index maxDepth) => + forall nBytes addrW calEntry maxDepth. + ( KnownNat nBytes + , 1 <= nBytes + , KnownNat maxDepth + , 2 <= maxDepth + , KnownNat addrW + , 2 <= addrW + , calEntry ~ Index maxDepth + ) => SNat maxDepth -> Gen (CalendarConfig nBytes addrW calEntry) genCalendarConfig sizeNat@(snatToNum -> dMax) = do @@ -80,17 +91,20 @@ genCalendarConfig sizeNat@(snatToNum -> dMax) = do dB <- Gen.enum 1 dMax case (TN.someNatVal dA, TN.someNatVal dB) of ( SomeNat (snatProxy -> depthA) - ,SomeNat (snatProxy -> depthB)) -> do + , SomeNat (snatProxy -> depthB) + ) -> do let regAddrBits = SNat @(2 + NatRequiredBits (Regs calEntry (nBytes * 8) + Cal.ExtraRegs)) bsCalEntry = SNat @(BitSize calEntry) - case - ( isInBounds d1 depthA sizeNat - , isInBounds d1 depthB sizeNat - , compareSNat regAddrBits (SNat @addrW) - , compareSNat d1 bsCalEntry) of + case ( isInBounds d1 depthA sizeNat + , isInBounds d1 depthB sizeNat + , compareSNat regAddrBits (SNat @addrW) + , compareSNat d1 bsCalEntry + ) of (InBounds, InBounds, SNatLE, SNatLE) -> go depthA depthB - (a, b, c, d) -> error [I.i| + (a, b, c, d) -> + error + [I.i| genCalendarConfig: calEntry constraints not satisfied: a: #{a} @@ -101,23 +115,33 @@ genCalendarConfig sizeNat@(snatToNum -> dMax) = do ... |] where - go :: forall depthA depthB . - ( 1 <= depthA - , 1 <= depthB - , LessThan depthA maxDepth - , LessThan depthB maxDepth) => - SNat depthA -> - SNat depthB -> - Gen (CalendarConfig nBytes addrW (Index maxDepth)) - go SNat SNat = do - calActive <- fmap nonRepeatingEntry . fromMaybe errmsg . fromList @depthA . - P.take (natToNum @depthA) <$> Gen.shuffle @_ @(Index maxDepth) - [0.. natToNum @(maxDepth-1)] - calShadow <- fmap nonRepeatingEntry . fromMaybe errmsg . fromList @depthB . - P.take (natToNum @depthB) <$> Gen.shuffle @_ @(Index maxDepth) - [0.. natToNum @(maxDepth-1)] - return $ CalendarConfig sizeNat calActive calShadow - errmsg = errorX "genCalendarConfig: list to vector conversion failed" + go :: + forall depthA depthB. + ( 1 <= depthA + , 1 <= depthB + , LessThan depthA maxDepth + , LessThan depthB maxDepth + ) => + SNat depthA -> + SNat depthB -> + Gen (CalendarConfig nBytes addrW (Index maxDepth)) + go SNat SNat = do + calActive <- + fmap nonRepeatingEntry + . fromMaybe errmsg + . fromList @depthA + . P.take (natToNum @depthA) + <$> Gen.shuffle @_ @(Index maxDepth) + [0 .. natToNum @(maxDepth - 1)] + calShadow <- + fmap nonRepeatingEntry + . fromMaybe errmsg + . fromList @depthB + . P.take (natToNum @depthB) + <$> Gen.shuffle @_ @(Index maxDepth) + [0 .. natToNum @(maxDepth - 1)] + return $ CalendarConfig sizeNat calActive calShadow + errmsg = errorX "genCalendarConfig: list to vector conversion failed" -- | Check if the scatter unit with wishbone interface loses no frames. scatterUnitNoFrameLoss :: Property @@ -136,24 +160,38 @@ scatterUnitNoFrameLoss = property $ do metaCycles <- forAll $ Gen.enum 1 10 let -- reset cycle + cycle delay, last metacycle's writes can be read in (metacycles + 1) - simLength = 2 + (1+metaCycles) * memDepth + simLength = 2 + (1 + metaCycles) * memDepth inputGen = Gen.list (Range.singleton metaCycles) metaCycleNothing = P.replicate memDepth Nothing -- Generate at most memDepth `div` 2 elements to be written each metacycle since -- we need two cycles to read a written element. metaCycleGen = genFrameList (Range.singleton $ memDepth `div` 2) - inputFrames <- forAll $ padToLength (simLength `div` memDepth + 1) metaCycleNothing - <$> inputGen (padToLength memDepth Nothing <$> metaCycleGen) + inputFrames <- + forAll + $ padToLength (simLength `div` memDepth + 1) metaCycleNothing + <$> inputGen (padToLength memDepth Nothing <$> metaCycleGen) let - topEntity (unbundle -> (wbIn, linkIn)) = fst $ - withClockResetEnable clockGen resetGen enableGen (scatterUnitWb @System @32) - (ScatterConfig calConfig) (pure emptyWishboneM2S) linkIn wbIn - - wbReadOps = P.take simLength $ P.replicate memDepth emptyWishboneM2S P.++ P.concat - ( padToLength memDepth emptyWishboneM2S - . P.concat - . P.zipWith wbRead (toList $ fmap veEntry calA) <$> inputFrames) + topEntity (unbundle -> (wbIn, linkIn)) = + fst + $ withClockResetEnable + clockGen + resetGen + enableGen + (scatterUnitWb @System @32) + (ScatterConfig calConfig) + (pure emptyWishboneM2S) + linkIn + wbIn + + wbReadOps = + P.take simLength $ P.replicate memDepth emptyWishboneM2S + P.++ P.concat + ( padToLength memDepth emptyWishboneM2S + . P.concat + . P.zipWith wbRead (toList $ fmap veEntry calA) + <$> inputFrames + ) topEntityInput = P.zip wbReadOps (P.concat inputFrames) simOut = simulateN simLength topEntity topEntityInput @@ -173,31 +211,44 @@ gatherUnitNoFrameLoss = property $ do where runTest :: (KnownNat maxSize, 1 <= maxSize) => - CalendarConfig 4 32 (Index maxSize) -> PropertyT IO () + CalendarConfig 4 32 (Index maxSize) -> + PropertyT IO () runTest calConfig@(CalendarConfig _ calA@(length -> memDepth) _) = do metaCycles <- forAll $ Gen.enum 1 10 let activeEntryList = toList $ fmap veEntry calA - simLength = 2 + (1+metaCycles) * memDepth + simLength = 2 + (1 + metaCycles) * memDepth inputGen = Gen.list (Range.singleton metaCycles) metaCycleNothing = P.replicate memDepth Nothing metaCycleGen = genFrameList (Range.singleton $ memDepth `div` 2) - inputFrames <- forAll $ padToLength (simLength `div` memDepth + 1) metaCycleNothing - <$> inputGen (padToLength memDepth Nothing <$> metaCycleGen) + inputFrames <- + forAll + $ padToLength (simLength `div` memDepth + 1) metaCycleNothing + <$> inputGen (padToLength memDepth Nothing <$> metaCycleGen) let - topEntity wbIn = (\ (a, _ ,_) -> a) $ - withClockResetEnable clockGen resetGen enableGen (gatherUnitWb @System @32) - (GatherConfig calConfig) (pure emptyWishboneM2S) wbIn - - wbWriteOps = P.take simLength . P.concat $ - padToLength memDepth emptyWishboneM2S . - P.concat . P.zipWith wbWrite activeEntryList - <$> inputFrames + topEntity wbIn = + (\(a, _, _) -> a) + $ withClockResetEnable + clockGen + resetGen + enableGen + (gatherUnitWb @System @32) + (GatherConfig calConfig) + (pure emptyWishboneM2S) + wbIn + + wbWriteOps = + P.take simLength + . P.concat + $ padToLength memDepth emptyWishboneM2S + . P.concat + . P.zipWith wbWrite activeEntryList + <$> inputFrames simOut = simulateN simLength topEntity wbWriteOps addressedFrames = P.zip (P.concat inputFrames) (cycle activeEntryList) writtenFrames = [if snd e /= 0 then fst e else Nothing | e <- addressedFrames] - prePad items = P.replicate (1+memDepth) Nothing P.++ items + prePad items = P.replicate (1 + memDepth) Nothing P.++ items expectedOutput = P.take simLength (fromMaybe 1 <$> P.filter isJust writtenFrames) footnote . fromString $ "simOut: " <> showX simOut @@ -214,10 +265,11 @@ directedDecode ((Just _) : as) ((Just b) : bs) = b : directedDecode as bs directedDecode (Nothing : as) (_ : bs) = directedDecode as bs directedDecode _ _ = [] --- | Simple test which generates a 'scatterUnitWb' and 'gatherUnitWb' with a certain calendar --- Their wishbone busses are statically hooked up to a transaction that reads from the --- stalling address. This test checks that it generates an acknowledge on this address --- one cycle after the end of each metacycle (at the start of every _new_ metacycle). +{- | Simple test which generates a 'scatterUnitWb' and 'gatherUnitWb' with a certain calendar +Their wishbone busses are statically hooked up to a transaction that reads from the +stalling address. This test checks that it generates an acknowledge on this address +one cycle after the end of each metacycle (at the start of every _new_ metacycle). +-} metacycleStalling :: Property metacycleStalling = property $ do maxCalSize <- forAll $ Gen.enum 2 32 @@ -226,35 +278,52 @@ metacycleStalling = property $ do runTest =<< forAll (genCalendarConfig @4 @32 p) where runTest :: - forall maxSize . + forall maxSize. (KnownNat maxSize, 2 <= maxSize) => - CalendarConfig 4 32 (Index maxSize) -> PropertyT IO () + CalendarConfig 4 32 (Index maxSize) -> + PropertyT IO () runTest calConfig@(CalendarConfig _ (length -> calSize) _) = do metacycles <- forAll $ Gen.enum 1 5 let simLength = 1 + metacycles * calSize - topEntity = bundle (acknowledge <$> suWB,acknowledge <$> guWB) + topEntity = bundle (acknowledge <$> suWB, acknowledge <$> guWB) where - suWB = wcre $ fst $ scatterUnitWb @System (ScatterConfig calConfig) - (pure emptyWishboneM2S) linkIn wbStall - guWB = wcre $ (\(_,x,_) -> x) $ gatherUnitWb @System - (GatherConfig calConfig) (pure emptyWishboneM2S) wbStall - wbStall = pure $ (emptyWishboneM2S @32) - -- 4 for word alignment, 2 because addressing is 64 bit aligned. - { addr = 4 * (2 * (natToNum @maxSize @(BitVector 32))) - , busCycle = True - , strobe = True - } + suWB = + wcre + $ fst + $ scatterUnitWb @System + (ScatterConfig calConfig) + (pure emptyWishboneM2S) + linkIn + wbStall + guWB = + wcre + $ (\(_, x, _) -> x) + $ gatherUnitWb @System + (GatherConfig calConfig) + (pure emptyWishboneM2S) + wbStall + wbStall = + pure + $ (emptyWishboneM2S @32) + { -- 4 for word alignment, 2 because addressing is 64 bit aligned. + addr = 4 * (2 * (natToNum @maxSize @(BitVector 32))) + , busCycle = True + , strobe = True + } linkIn = pure $ deepErrorX "linkIn undefined." - expectedAcks = P.take simLength $ P.replicate (1 +calSize) False <> - cycle (True : P.replicate (calSize -1) False) + expectedAcks = + P.take simLength + $ P.replicate (1 + calSize) False + <> cycle (True : P.replicate (calSize - 1) False) simOut = sampleN simLength topEntity - simOut === fmap (\a -> (a,a)) expectedAcks + simOut === fmap (\a -> (a, a)) expectedAcks --- | Decode an incoming slave bus by consuming two acknowledged signals and concatenating --- their readData's. +{- | Decode an incoming slave bus by consuming two acknowledged signals and concatenating +their readData's. +-} wbDecoding :: - KnownNat nBytes => + (KnownNat nBytes) => [WishboneS2M (Bytes nBytes)] -> [Bytes (nBytes + nBytes)] wbDecoding (s2m0 : s2m1 : s2ms) @@ -264,60 +333,66 @@ wbDecoding (s2m0 : s2m1 : s2ms) out = readData s2m0 ++# readData s2m1 wbDecoding _ = [] --- | Tranform a read address with expected frame into a wishbone read operation for testing --- the 'scatterUnitWb'. The second argument indicate wether or not a frame can be read from --- that read address. The read operation reads data over 2 read cycles. +{- | Tranform a read address with expected frame into a wishbone read operation for testing +the 'scatterUnitWb'. The second argument indicate wether or not a frame can be read from +that read address. The read operation reads data over 2 read cycles. +-} wbRead :: - forall nBytes addrW maxIndex a . + forall nBytes addrW maxIndex a. ( KnownNat nBytes , KnownNat addrW , KnownNat maxIndex - , 1 <= maxIndex) => + , 1 <= maxIndex + ) => Index maxIndex -> Maybe a -> [WishboneM2S addrW nBytes (Bytes nBytes)] wbRead readAddr (Just _) = [ (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = (`shiftL` 3) . resize $ pack readAddr - , busCycle = True - , strobe = True - , busSelect = maxBound } - + { addr = (`shiftL` 3) . resize $ pack readAddr + , busCycle = True + , strobe = True + , busSelect = maxBound + } , (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = 4 .|. ((`shiftL` 3) . resize $ pack readAddr) - , busCycle = True - , strobe = True - , busSelect = maxBound } + { addr = 4 .|. ((`shiftL` 3) . resize $ pack readAddr) + , busCycle = True + , strobe = True + , busSelect = maxBound + } ] wbRead _ Nothing = [] --- | Transform a write address with frame to a wishbone write operation for testing the --- 'gatherUnitWb'. The write operation writes the incoming bitvector over 2 write cycles. +{- | Transform a write address with frame to a wishbone write operation for testing the +'gatherUnitWb'. The write operation writes the incoming bitvector over 2 write cycles. +-} wbWrite :: - forall nBytes addrW maxIndex . + forall nBytes addrW maxIndex. ( KnownNat nBytes , KnownNat addrW , KnownNat maxIndex - , 1 <= maxIndex) => + , 1 <= maxIndex + ) => Index maxIndex -> - Maybe (Bytes (nBytes*2)) -> + Maybe (Bytes (nBytes * 2)) -> [WishboneM2S addrW nBytes (Bytes nBytes)] wbWrite writeAddr (Just frame) = [ (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = (`shiftL` 3) . resize $ pack writeAddr - , busSelect = maxBound - , busCycle = True - , strobe = True - , writeEnable = True - , writeData = lower } - + { addr = (`shiftL` 3) . resize $ pack writeAddr + , busSelect = maxBound + , busCycle = True + , strobe = True + , writeEnable = True + , writeData = lower + } , (emptyWishboneM2S @addrW @(Bytes nBytes)) - { addr = 4 .|. ((`shiftL` 3) . resize $ pack writeAddr) - , busSelect = maxBound - , busCycle = True - , strobe = True - , writeEnable = True - , writeData = upper } + { addr = 4 .|. ((`shiftL` 3) . resize $ pack writeAddr) + , busSelect = maxBound + , busCycle = True + , strobe = True + , writeEnable = True + , writeData = upper + } ] where (lower, upper) = split frame diff --git a/bittide/tests/Tests/Shared.hs b/bittide/tests/Tests/Shared.hs index d508c5daa..4d3f489fc 100644 --- a/bittide/tests/Tests/Shared.hs +++ b/bittide/tests/Tests/Shared.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} @@ -12,13 +11,13 @@ import Clash.Prelude import Clash.Hedgehog.Sized.Unsigned -import Data.Constraint (Dict(Dict)) +import Data.Constraint (Dict (Dict)) import Data.Constraint.Nat.Extra (divWithRemainder) import GHC.Stack (HasCallStack) import Hedgehog -import Protocols (toSignals, Circuit(..)) +import Protocols (Circuit (..), toSignals) import Protocols.Wishbone as Wb -import Protocols.Wishbone.Standard.Hedgehog (validatorCircuit, WishboneMasterRequest(..)) +import Protocols.Wishbone.Standard.Hedgehog (WishboneMasterRequest (..), validatorCircuit) import Bittide.Calendar import Bittide.SharedTypes @@ -27,7 +26,6 @@ import qualified Data.List as L import qualified GHC.TypeNats as TypeNats import qualified Hedgehog.Range as Range - data IsInBounds a b c where InBounds :: (a <= b, b <= c) => IsInBounds a b c NotInBounds :: IsInBounds a b c @@ -50,9 +48,10 @@ isInBounds a b c = case (compareSNat a b, compareSNat b c) of (SNatLE, SNatLE) -> InBounds _ -> NotInBounds --- | We use a custom generator for BitVector's because the current Clash implementation --- uses genVec which is slow. -genDefinedBitVector :: forall n m . (MonadGen m, KnownNat n) => m (BitVector n) +{- | We use a custom generator for BitVector's because the current Clash implementation +uses genVec which is slow. +-} +genDefinedBitVector :: forall n m. (MonadGen m, KnownNat n) => m (BitVector n) genDefinedBitVector = pack <$> genUnsigned Range.constantBounded -- | Single datatype to represent successful and unsuccessful Wishbone transactions. @@ -64,22 +63,22 @@ data Transaction addrW selWidth a | Stall (WishboneM2S addrW selWidth a) | Ignored (WishboneM2S addrW selWidth a) | Illegal (WishboneM2S addrW selWidth a) (WishboneS2M a) - deriving (Generic) + deriving (Generic) -- | Show Instance for 'Transaction' that hides fields irrelevant for the transaction. instance (KnownNat addrW, Show a) => Show (Transaction addrW selWidth a) where - show (WriteSuccess WishboneM2S{..} _) - = "WriteSuccess: (addr: " - <> show addr - <> ", writeData:" - <> show writeData - <> ")" - show (ReadSuccess WishboneM2S{..} WishboneS2M{..}) - = "ReadSuccess: (" - <> show addr - <> ", " - <> show readData - <> ")" + show (WriteSuccess WishboneM2S{..} _) = + "WriteSuccess: (addr: " + <> show addr + <> ", writeData:" + <> show writeData + <> ")" + show (ReadSuccess WishboneM2S{..} WishboneS2M{..}) = + "ReadSuccess: (" + <> show addr + <> ", " + <> show readData + <> ")" show (Error _) = "Error" show (Retry _) = "Retry" show (Stall _) = "Stall" @@ -88,36 +87,39 @@ instance (KnownNat addrW, Show a) => Show (Transaction addrW selWidth a) where -- | Show Instance for 'Transaction' that hides fields irrelevant for the transaction. instance (KnownNat addrW, KnownNat selWidth, ShowX a) => ShowX (Transaction addrW selWidth a) where - showX (WriteSuccess WishboneM2S{..} _) - = "WriteSuccess: (addr: " - <> showX addr - <> ", writeData:" - <> showX writeData - <> ")" - showX (ReadSuccess WishboneM2S{..} WishboneS2M{..}) - = "ReadSuccess: (" - <> showX addr - <> ", " - <> showX readData - <> ")" + showX (WriteSuccess WishboneM2S{..} _) = + "WriteSuccess: (addr: " + <> showX addr + <> ", writeData:" + <> showX writeData + <> ")" + showX (ReadSuccess WishboneM2S{..} WishboneS2M{..}) = + "ReadSuccess: (" + <> showX addr + <> ", " + <> showX readData + <> ")" showX (Error _) = "Error" showX (Retry _) = "Retry" showX (Stall _) = "Stall" showX (Illegal _ _) = "Illegal" showX (Ignored _) = "Ignored" --- | Equality instance for 'Transaction' that only looks at the fields relevant for the --- transaction (e.g. 'writeData' is not relevant during a read transaction). -instance (KnownNat addrW, KnownNat selWidth, Eq a, NFDataX a) => - Eq (Transaction addrW selWidth a) where +{- | Equality instance for 'Transaction' that only looks at the fields relevant for the +transaction (e.g. 'writeData' is not relevant during a read transaction). +-} +instance + (KnownNat addrW, KnownNat selWidth, Eq a, NFDataX a) => + Eq (Transaction addrW selWidth a) + where (WriteSuccess mA _) == (WriteSuccess mB _) = - checkField "addr" addr mA mB && - checkField "buSelect" busSelect mA mB && - checkField "writeData" writeData mA mB + checkField "addr" addr mA mB + && checkField "buSelect" busSelect mA mB + && checkField "writeData" writeData mA mB (ReadSuccess mA sA) == (ReadSuccess mB sB) = - checkField "addr" addr mA mB && - checkField "busSelect" busSelect mA mB && - checkField "readData" readData sA sB + checkField "addr" addr mA mB + && checkField "busSelect" busSelect mA mB + && checkField "readData" readData sA sB (Error _) == (Error _) = True (Retry _) == (Retry _) = True (Stall _) == (Stall _) = True @@ -128,36 +130,36 @@ instance (KnownNat addrW, KnownNat selWidth, Eq a, NFDataX a) => checkField :: (NFDataX a, Eq a) => String -> (t -> a) -> t -> t -> Bool checkField str f a b | hasUndefined (f a) || hasUndefined (f b) = - deepErrorX ("checkField: " <> str <> ", is undefined for one of the transactions.") + deepErrorX ("checkField: " <> str <> ", is undefined for one of the transactions.") | otherwise = f a == f b --- | Consumes a list of 'WishboneM2S' requests and a list of 'WishboneS2M' responses --- and transforms them to a list of 'Transaction'. -wbToTransaction - :: (Eq a, KnownNat addressWidth, KnownNat selWidth, ShowX a) - => [WishboneM2S addressWidth selWidth a] - -> [WishboneS2M a] - -> [Transaction addressWidth selWidth a] -wbToTransaction (m@WishboneM2S{..}:restM) (s@WishboneS2M{..}:restS) - | not strobe || not busCycle = nextTransaction - | hasMultipleTrues [acknowledge, err, retry, stall] = Illegal m s : nextTransaction - | acknowledge && writeEnable = WriteSuccess m s : nextTransaction - | acknowledge = ReadSuccess m s : nextTransaction - | err = Error m : nextTransaction - | retry = Retry m : nextTransaction - | stall = Stall m : nextTransaction - | Wb.busCycle nextM && Wb.strobe nextM = nextTransaction - | otherwise = Ignored m : nextTransaction +{- | Consumes a list of 'WishboneM2S' requests and a list of 'WishboneS2M' responses +and transforms them to a list of 'Transaction'. +-} +wbToTransaction :: + (Eq a, KnownNat addressWidth, KnownNat selWidth, ShowX a) => + [WishboneM2S addressWidth selWidth a] -> + [WishboneS2M a] -> + [Transaction addressWidth selWidth a] +wbToTransaction (m@WishboneM2S{..} : restM) (s@WishboneS2M{..} : restS) + | not strobe || not busCycle = nextTransaction + | hasMultipleTrues [acknowledge, err, retry, stall] = Illegal m s : nextTransaction + | acknowledge && writeEnable = WriteSuccess m s : nextTransaction + | acknowledge = ReadSuccess m s : nextTransaction + | err = Error m : nextTransaction + | retry = Retry m : nextTransaction + | stall = Stall m : nextTransaction + | Wb.busCycle nextM && Wb.strobe nextM = nextTransaction + | otherwise = Ignored m : nextTransaction where nextM = L.head restM nextTransaction = wbToTransaction restM restS hasMultipleTrues :: [Bool] -> Bool hasMultipleTrues [] = False hasMultipleTrues [_] = False - hasMultipleTrues (b0:(b1:brest)) - | b0 && b1 = True + hasMultipleTrues (b0 : (b1 : brest)) + | b0 && b1 = True | otherwise = hasMultipleTrues ((b0 || b1) : brest) - wbToTransaction _ _ = [] -- | Take a wishbone master and a wishbone slave and return their transactions. @@ -178,7 +180,7 @@ exposeWbTransactions maybeSampleLength (Circuit master) (Circuit slave) = -- | Transform a `WishboneMasterRequest` into `WishboneM2S` wbMasterRequestToM2S :: - forall addrW a . + forall addrW a. ( KnownNat addrW , KnownNat (BitSize a) , NFDataX a @@ -186,39 +188,42 @@ wbMasterRequestToM2S :: WishboneMasterRequest addrW a -> WishboneM2S addrW (DivRU (BitSize a) 8) a wbMasterRequestToM2S = \case - Read i busSelect -> (emptyWishboneM2S @addrW @a) - { addr = resize (pack i) - , busCycle = True - , strobe = True - , busSelect = busSelect - , writeEnable = True - } - Write i busSelect a -> (emptyWishboneM2S @addrW @a) - { addr = resize (pack i) - , busCycle = True - , strobe = True - , busSelect = busSelect - , writeEnable = True - , writeData = a} - --- | Consumes a list of 'RamOp's and a list of corresponding results @a@ and transforms --- them into a list of 'Transaction's. -wbOpToTransaction - :: - forall addrW a . + Read i busSelect -> + (emptyWishboneM2S @addrW @a) + { addr = resize (pack i) + , busCycle = True + , strobe = True + , busSelect = busSelect + , writeEnable = True + } + Write i busSelect a -> + (emptyWishboneM2S @addrW @a) + { addr = resize (pack i) + , busCycle = True + , strobe = True + , busSelect = busSelect + , writeEnable = True + , writeData = a + } + +{- | Consumes a list of 'RamOp's and a list of corresponding results @a@ and transforms +them into a list of 'Transaction's. +-} +wbOpToTransaction :: + forall addrW a. ( KnownNat addrW , KnownNat (BitSize a) , NFDataX a - ) - => WishboneMasterRequest addrW a - -> a - -> Transaction addrW (DivRU (BitSize a) 8) a + ) => + WishboneMasterRequest addrW a -> + a -> + Transaction addrW (DivRU (BitSize a) 8) a wbOpToTransaction ramOp response = case ramOp of Read _ _ -> ReadSuccess wbM2S slaveResponse Write _ _ _ -> WriteSuccess wbM2S slaveResponse where wbM2S = wbMasterRequestToM2S ramOp - slaveResponse = (emptyWishboneS2M @a) {acknowledge = True, readData = response} + slaveResponse = (emptyWishboneS2M @a){acknowledge = True, readData = response} validateWb :: forall dom aw bs. @@ -235,7 +240,7 @@ validateWb m2s0 s2m0 = (m2s1, s2m1) validate (m2s0, s2m0) -- | Satisfies implicit control signal constraints by using default values. -wcre :: KnownDomain dom => (HiddenClockResetEnable dom => r) -> r +wcre :: (KnownDomain dom) => ((HiddenClockResetEnable dom) => r) -> r wcre = withClockResetEnable clockGen resetGen enableGen -- | Make any @a@ into a non-repeating `ValidEntry` without repetition bits. diff --git a/bittide/tests/Tests/StabilityChecker.hs b/bittide/tests/Tests/StabilityChecker.hs index 03e078a7c..239b9a8dc 100644 --- a/bittide/tests/Tests/StabilityChecker.hs +++ b/bittide/tests/Tests/StabilityChecker.hs @@ -1,13 +1,11 @@ -- SPDX-FileCopyrightText: 2022 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE OverloadedStrings #-} module Tests.StabilityChecker where - -import Clash.Prelude hiding ((^), someNatVal) +import Clash.Prelude hiding (someNatVal, (^)) import Prelude ((^)) import Clash.Hedgehog.Sized.Signed (genSigned) @@ -23,15 +21,20 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range tests :: TestTree -tests = testGroup "Tests.StabilityChecker" - [ testPropertyNamed "stabilityCheckerTest behaves the same as its golden reference" - "stabilityCheckerTest" stabilityCheckerTest] +tests = + testGroup + "Tests.StabilityChecker" + [ testPropertyNamed + "stabilityCheckerTest behaves the same as its golden reference" + "stabilityCheckerTest" + stabilityCheckerTest + ] stabilityCheckerTest :: Property stabilityCheckerTest = property $ do dataCountBits <- forAll $ Gen.integral $ Range.linear 2 128 - cyclesStable <- forAll $ Gen.integral $ Range.linear 1 128 - margin <- forAll $ Gen.integral $ Range.linear 0 (2^dataCountBits - 1) + cyclesStable <- forAll $ Gen.integral $ Range.linear 1 128 + margin <- forAll $ Gen.integral $ Range.linear 0 (2 ^ dataCountBits - 1) -- Convert generated variables to type level ones case ( someSNat dataCountBits @@ -51,8 +54,11 @@ stabilityCheckerTest = property $ do PropertyT IO () prop SNat sCyclesStable@SNat sMargin@SNat = do simLength <- forAll $ Gen.integral (Range.linear 4 1024) - dataCounts <- forAll $ Gen.list (Range.singleton simLength) - (genSigned @_ @dataCountBits Range.constantBounded) + dataCounts <- + forAll + $ Gen.list + (Range.singleton simLength) + (genSigned @_ @dataCountBits Range.constantBounded) let topEntity = wcre $ fmap stable . stabilityChecker @System sMargin sCyclesStable simOut = simulateN simLength topEntity dataCounts @@ -60,16 +66,16 @@ stabilityCheckerTest = property $ do simOut === golden (snatToNum sMargin) (snatToNum sCyclesStable) dataCounts -- 'stabilityChecker' reference design - golden :: forall n . KnownNat n => Integer -> Integer -> [RelDataCount n] -> [Bool] + golden :: forall n. (KnownNat n) => Integer -> Integer -> [RelDataCount n] -> [Bool] golden margin cyclesStable dataCounts = f - (0, fromIntegral (targetDataCount :: RelDataCount n)) - (fmap fromIntegral dataCounts) + (0, fromIntegral (targetDataCount :: RelDataCount n)) + (fmap fromIntegral dataCounts) where f _ [] = [] - f (!cnt, target) (x:xs) - | inMargin && cnt >= cyclesStable = True : f (cnt + 1, target) xs - | inMargin = False : f (cnt + 1, target) xs - | otherwise = False : f (0, x) xs + f (!cnt, target) (x : xs) + | inMargin && cnt >= cyclesStable = True : f (cnt + 1, target) xs + | inMargin = False : f (cnt + 1, target) xs + | otherwise = False : f (0, x) xs where inMargin = abs (x - target) <= margin diff --git a/bittide/tests/Tests/Switch.hs b/bittide/tests/Tests/Switch.hs index dbd0f3717..d0a0c3b04 100644 --- a/bittide/tests/Tests/Switch.hs +++ b/bittide/tests/Tests/Switch.hs @@ -1,21 +1,19 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - -{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} - {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -module Tests.Switch(tests) where +module Tests.Switch (tests) where import Clash.Prelude import Clash.Hedgehog.Sized.Index import Clash.Hedgehog.Sized.Vector -import Clash.Sized.Vector ( unsafeFromList) +import Clash.Sized.Vector (unsafeFromList) import Data.String import Hedgehog import Protocols.Wishbone @@ -34,12 +32,14 @@ import qualified Hedgehog.Range as Range import qualified Prelude as P tests :: TestTree -tests = testGroup "Tests.Switch" - [testPropertyNamed "Routing works" "switchFrameRoutingWorks" switchFrameRoutingWorks] +tests = + testGroup + "Tests.Switch" + [testPropertyNamed "Routing works" "switchFrameRoutingWorks" switchFrameRoutingWorks] -data SwitchTestConfig nBytes addrW where +data SwitchTestConfig nBytes addrW where SwitchTestConfig :: - ( KnownNat links, 1 <= nBytes, 2 <= addrW) => + (KnownNat links, 1 <= nBytes, 2 <= addrW) => SwitchConfig links nBytes addrW -> SwitchTestConfig nBytes addrW @@ -47,16 +47,17 @@ deriving instance Show (SwitchTestConfig nBytes addrW) -- This generator can generate a calendar entry for a switch given the amount of links. genSwitchEntry :: - forall links . + forall links. SNat links -> Gen (ValidEntry (CalendarEntry links) 0) genSwitchEntry SNat = genValidEntry SNat (genVec (genIndex Range.constantBounded)) --- | This generator can generate a calendar for the bittide switch, knowing the --- amount of bytes and address width of the wishbone bus, and given the amount of links and --- calendar depth of the switch. +{- | This generator can generate a calendar for the bittide switch, knowing the +amount of bytes and address width of the wishbone bus, and given the amount of links and +calendar depth of the switch. +-} genSwitchCalendar :: - forall nBytes addrW . + forall nBytes addrW. (KnownNat nBytes, 1 <= nBytes, KnownNat addrW, 2 <= addrW) => Natural -> Natural -> @@ -65,9 +66,13 @@ genSwitchCalendar links calDepth = do case TN.someNatVal links of (SomeNat (snatProxy -> l)) -> do testCal <- genCalendarConfig calDepth $ genSwitchEntry l - return $ SwitchTestConfig (SwitchConfig - { preamble = errorX "preamble Undefined" :: BitVector 64 - , calendarConfig = testCal}) + return + $ SwitchTestConfig + ( SwitchConfig + { preamble = errorX "preamble Undefined" :: BitVector 64 + , calendarConfig = testCal + } + ) -- | This test checks that for any switch calendar all outputs select the correct frame. switchFrameRoutingWorks :: Property @@ -78,33 +83,42 @@ switchFrameRoutingWorks = property $ do case switchCal of SwitchTestConfig ( SwitchConfig - { preamble = preamble - , calendarConfig = calConfig@(CalendarConfig _ (toList . fmap (toList . veEntry) -> cal) _) - } - ) -> do - simLength <- forAll $ Gen.enum 1 (2 * fromIntegral calDepth) - let - genFrame = Just <$> genDefinedBitVector @64 - allLinks = Gen.list (Range.singleton links) genFrame - topEntityInput <- forAll $ Gen.list (Range.singleton simLength) allLinks - let - topEntity streamsIn = withClockResetEnable clockGen resetGen enableGen $ bundle $ - fst $ switch preamble calConfig (pure emptyWishboneM2S) - (repeat $ pure emptyWishboneM2S) (repeat $ pure emptyWishboneM2S) $ unbundle streamsIn - simOut = simulateN @System simLength topEntity $ fmap unsafeFromList topEntityInput - let - expectedFrames = P.replicate links Nothing : topEntityInput - expectedOutput = P.take simLength $ P.replicate links Nothing : - P.zipWith selectAllOutputs expectedFrames (cycle cal) - footnote . fromString $ "expected:" <> showX expectedOutput - footnote . fromString $ "simOut: " <> showX simOut - footnote . fromString $ "input: " <> showX topEntityInput - fmap toList simOut === expectedOutput + { preamble = preamble + , calendarConfig = calConfig@(CalendarConfig _ (toList . fmap (toList . veEntry) -> cal) _) + } + ) -> do + simLength <- forAll $ Gen.enum 1 (2 * fromIntegral calDepth) + let + genFrame = Just <$> genDefinedBitVector @64 + allLinks = Gen.list (Range.singleton links) genFrame + topEntityInput <- forAll $ Gen.list (Range.singleton simLength) allLinks + let + topEntity streamsIn = + withClockResetEnable clockGen resetGen enableGen + $ bundle + $ fst + $ switch + preamble + calConfig + (pure emptyWishboneM2S) + (repeat $ pure emptyWishboneM2S) + (repeat $ pure emptyWishboneM2S) + $ unbundle streamsIn + simOut = simulateN @System simLength topEntity $ fmap unsafeFromList topEntityInput + let + expectedFrames = P.replicate links Nothing : topEntityInput + expectedOutput = + P.take simLength $ P.replicate links Nothing + : P.zipWith selectAllOutputs expectedFrames (cycle cal) + footnote . fromString $ "expected:" <> showX expectedOutput + footnote . fromString $ "simOut: " <> showX simOut + footnote . fromString $ "input: " <> showX topEntityInput + fmap toList simOut === expectedOutput selectAllOutputs :: (KnownNat l) => [Maybe a] -> - [Index (l+1)] -> + [Index (l + 1)] -> [Maybe a] selectAllOutputs incomingFrames = fmap (selectionFunc . fromEnum) where diff --git a/bittide/tests/Tests/Transceiver.hs b/bittide/tests/Tests/Transceiver.hs index 70d3aa974..044b4863d 100644 --- a/bittide/tests/Tests/Transceiver.hs +++ b/bittide/tests/Tests/Transceiver.hs @@ -6,7 +6,6 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} - {-# OPTIONS_GHC -Wno-orphans #-} module Tests.Transceiver where @@ -22,10 +21,10 @@ import Clash.Cores.Xilinx.GTH (GthCore) import Clash.Hedgehog.Sized.Index (genIndex) import Clash.Signal.Internal (Signal ((:-))) import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy(Proxy)) -import Data.Sequence (Seq((:|>), (:<|))) -import Test.Tasty (TestTree, testGroup, adjustOption) -import Test.Tasty.Hedgehog (testPropertyNamed, HedgehogTestLimit (HedgehogTestLimit)) +import Data.Proxy (Proxy (Proxy)) +import Data.Sequence (Seq ((:<|), (:|>))) +import Test.Tasty (TestTree, adjustOption, testGroup) +import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit), testPropertyNamed) import qualified Bittide.Transceiver as Transceiver import qualified Bittide.Transceiver.ResetManager as ResetManager @@ -35,33 +34,35 @@ import qualified Data.Sequence as Seq import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range - -createDomain vSystem{vName="RefIsUnused"} +createDomain vSystem{vName = "RefIsUnused"} -- Note that these domains are a factor of ~5_000 slower than we use in practise. We -- do this because timeouts in the transceivers are specified in milliseconds, which -- makes the simulation simply do "nothing" for a while. Also note the frequencies -- of domain A and B are slightly different - which is a realistic property of -- clocks - though the order of difference is very much exaggerated. -createDomain vSystem{vName="A", vResetKind=Synchronous, vPeriod=hzToPeriod 60e3} -createDomain vSystem{vName="B", vResetKind=Synchronous, vPeriod=hzToPeriod 61e3} - --- | The free domain should be able to run at any speed, so we specify one that is --- much slower than the A/B domains, one that is approximately the same, and one --- that is much faster. -createDomain vSystem{vName="FreeSlow", vResetKind=Synchronous, vPeriod=hzToPeriod 10e3} -createDomain vSystem{vName="Free", vResetKind=Synchronous, vPeriod=hzToPeriod 60e3} -createDomain vSystem{vName="FreeFast", vResetKind=Synchronous, vPeriod=hzToPeriod 120e3} - --- | A signal that changes every cycle. It is used to simulate the RX's data when --- it's receiving nothing. In theory this is white noise, in practise its a --- rotating bit pattern. -noise :: KnownDomain dom => Clock dom -> Signal dom (BitVector 64) +createDomain vSystem{vName = "A", vResetKind = Synchronous, vPeriod = hzToPeriod 60e3} +createDomain vSystem{vName = "B", vResetKind = Synchronous, vPeriod = hzToPeriod 61e3} + +{- | The free domain should be able to run at any speed, so we specify one that is +much slower than the A/B domains, one that is approximately the same, and one +that is much faster. +-} +createDomain + vSystem{vName = "FreeSlow", vResetKind = Synchronous, vPeriod = hzToPeriod 10e3} +createDomain vSystem{vName = "Free", vResetKind = Synchronous, vPeriod = hzToPeriod 60e3} +createDomain + vSystem{vName = "FreeFast", vResetKind = Synchronous, vPeriod = hzToPeriod 120e3} + +{- | A signal that changes every cycle. It is used to simulate the RX's data when +it's receiving nothing. In theory this is white noise, in practise its a +rotating bit pattern. +-} +noise :: (KnownDomain dom) => Clock dom -> Signal dom (BitVector 64) noise clk = let c = register clk noReset enableGen 0xdead_beef_ca55_e77e (rotateL <$> c <*> 1) in c - -- | Non-translatable, quick-to-simulate chain of \"dflipflops\"s delaySeqN :: Natural -> a -> Signal dom a -> Signal dom a delaySeqN 0 _dflt = id @@ -74,10 +75,10 @@ delaySeqN n dflt = go (Seq.fromFunction (fromIntegral n) (const dflt)) {-# ANN delaySeqN dontTranslate #-} {-# OPAQUE delaySeqN #-} - --- | Very simple model of a GTH core. Is modelled as if the serial domains and --- the word domains run at the same frequency. I.e.., it doesn't serialize at --- all. +{- | Very simple model of a GTH core. Is modelled as if the serial domains and +the word domains run at the same frequency. I.e.., it doesn't serialize at +all. +-} gthCoreMock :: String -> -- | Number of cycles it takes for RX's domain to be stable @@ -88,63 +89,70 @@ gthCoreMock :: Natural -> -- Offset Index 8 -> - GthCore tx rx ref free tx rx (Maybe (BitVector 64)) gthCoreMock _name - nRxResetCycles nTxResetCycles nTxDoneCycles offset - _channelName _clockPath rxSerial _rxSerial - freeClk - rstAll rstRx txWord _txCtrl - _refClk - = ( txSerial, txSerial, txClk, rxClk - , rxWord, pack <$> txDone, pack <$> rxDone, pack <$> txActive - , 0, 0, 0, 0 - ) - where - rxWord = - withClock rxClk $ - WordAlign.aligner WordAlign.dealignLsbFirst (pure False) (pure offset) $ - fromMaybe <$> noise rxClk <*> rxSerial - - txSerial = Just <$> txWord - - registerRx = register rxClk rxRstRx enableGen - registerTx = register txClk txRstAll enableGen - - rxResetCounter = registerRx nRxResetCycles (predSatZeroNatural <$> rxResetCounter) - txResetCounter = registerTx nTxResetCycles (predSatZeroNatural <$> txResetCounter) - txDoneCounter = registerTx (nTxResetCycles + nTxDoneCycles) (predSatZeroNatural <$> txDoneCounter) - - rxDone = rxResetCounter .==. 0 - txActive = txResetCounter .==. 0 - txDone = txDoneCounter .==. 0 - - txClk = clockGen - rxClk = clockGen - - txRstAll = unsafeFromActiveHigh (unsafeSynchronizer freeClk txClk (unsafeToActiveHigh rstAll)) - rxRstAll = unsafeFromActiveHigh (unsafeSynchronizer freeClk rxClk (unsafeToActiveHigh rstAll)) - rxRstRx = unsafeOrReset - rxRstAll - (unsafeFromActiveHigh (unsafeSynchronizer freeClk rxClk (unsafeToActiveHigh rstRx))) - - predSatZeroNatural :: Natural -> Natural - predSatZeroNatural 0 = 0 - predSatZeroNatural n = n - 1 + _refClk = + ( txSerial + , txSerial + , txClk + , rxClk + , rxWord + , pack <$> txDone + , pack <$> rxDone + , pack <$> txActive + , 0 + , 0 + , 0 + , 0 + ) + where + rxWord = + withClock rxClk + $ WordAlign.aligner WordAlign.dealignLsbFirst (pure False) (pure offset) + $ fromMaybe + <$> noise rxClk + <*> rxSerial + + txSerial = Just <$> txWord + + registerRx = register rxClk rxRstRx enableGen + registerTx = register txClk txRstAll enableGen + + rxResetCounter = registerRx nRxResetCycles (predSatZeroNatural <$> rxResetCounter) + txResetCounter = registerTx nTxResetCycles (predSatZeroNatural <$> txResetCounter) + txDoneCounter = registerTx (nTxResetCycles + nTxDoneCycles) (predSatZeroNatural <$> txDoneCounter) + + rxDone = rxResetCounter .==. 0 + txActive = txResetCounter .==. 0 + txDone = txDoneCounter .==. 0 + + txClk = clockGen + rxClk = clockGen + + txRstAll = unsafeFromActiveHigh (unsafeSynchronizer freeClk txClk (unsafeToActiveHigh rstAll)) + rxRstAll = unsafeFromActiveHigh (unsafeSynchronizer freeClk rxClk (unsafeToActiveHigh rstAll)) + rxRstRx = + unsafeOrReset + rxRstAll + (unsafeFromActiveHigh (unsafeSynchronizer freeClk rxClk (unsafeToActiveHigh rstRx))) + + predSatZeroNatural :: Natural -> Natural + predSatZeroNatural 0 = 0 + predSatZeroNatural n = n - 1 data Input tx rx = Input { dat :: Signal tx (BitVector 64) @@ -153,12 +161,16 @@ data Input tx rx = Input } dut :: - forall freeA freeB txA txB ref n . + forall freeA freeB txA txB ref n. ( KnownDomain ref - , HasSynchronousReset txA, HasDefinedInitialValues txA - , HasSynchronousReset txB, HasDefinedInitialValues txB - , HasSynchronousReset freeA, HasDefinedInitialValues freeA - , HasSynchronousReset freeB, HasDefinedInitialValues freeB + , HasSynchronousReset txA + , HasDefinedInitialValues txA + , HasSynchronousReset txB + , HasDefinedInitialValues txB + , HasSynchronousReset freeA + , HasDefinedInitialValues freeA + , HasSynchronousReset freeB + , HasDefinedInitialValues freeB ) => -- | Number of word clock cycles delay from A -> B Natural -> @@ -177,42 +189,53 @@ dut :: , Transceiver.Output txB txA txB freeB (Maybe (Bytes n)) ) dut - abDelay baDelay resetManagerConfig gthCoreA gthCoreB - freeClkA freeRstA freeClkB freeRstB inputA inputB = (outputA, outputB) - where - outputA = Transceiver.transceiverPrbsWith - gthCoreA - Transceiver.defConfig{Transceiver.resetManagerConfig} - Transceiver.Input - { clock = freeClkA - , reset = freeRstA - , refClock = error "A: refClock not used in simulation" - , transceiverIndex = 0 - , channelName = "A" - , clockPath = "clkA" - , rxN = delaySeqN baDelay Nothing outputB.txN - , rxP = error "A: rxP not used in simulation" - , txData = inputA.dat - , txReady = inputA.txReady - , rxReady = inputA.rxReady - } - - outputB = Transceiver.transceiverPrbsWith - gthCoreB - Transceiver.defConfig{Transceiver.resetManagerConfig} - Transceiver.Input - { clock = freeClkB - , reset = freeRstB - , refClock = error "B: refClock not used in simulation" - , transceiverIndex = 1 - , channelName = "B" - , clockPath = "clkB" - , rxN = delaySeqN abDelay Nothing outputA.txN - , rxP = error "B: rxP not used in simulation" - , txData = inputB.dat - , txReady = inputB.txReady - , rxReady = inputB.rxReady - } + abDelay + baDelay + resetManagerConfig + gthCoreA + gthCoreB + freeClkA + freeRstA + freeClkB + freeRstB + inputA + inputB = (outputA, outputB) + where + outputA = + Transceiver.transceiverPrbsWith + gthCoreA + Transceiver.defConfig{Transceiver.resetManagerConfig} + Transceiver.Input + { clock = freeClkA + , reset = freeRstA + , refClock = error "A: refClock not used in simulation" + , transceiverIndex = 0 + , channelName = "A" + , clockPath = "clkA" + , rxN = delaySeqN baDelay Nothing outputB.txN + , rxP = error "A: rxP not used in simulation" + , txData = inputA.dat + , txReady = inputA.txReady + , rxReady = inputA.rxReady + } + + outputB = + Transceiver.transceiverPrbsWith + gthCoreB + Transceiver.defConfig{Transceiver.resetManagerConfig} + Transceiver.Input + { clock = freeClkB + , reset = freeRstB + , refClock = error "B: refClock not used in simulation" + , transceiverIndex = 1 + , channelName = "B" + , clockPath = "clkB" + , rxN = delaySeqN abDelay Nothing outputA.txN + , rxP = error "B: rxP not used in simulation" + , txData = inputB.dat + , txReady = inputB.txReady + , rxReady = inputB.rxReady + } type DutTestFunc txA txB free = Transceiver.Output txA txB txA free (Maybe (BitVector 64)) -> @@ -224,10 +247,13 @@ type InputFunc txA txB free = Input txA txB dutRandomized :: - forall txA txB free . - ( HasSynchronousReset txA, HasDefinedInitialValues txA - , HasSynchronousReset txB, HasDefinedInitialValues txB - , HasSynchronousReset free, HasDefinedInitialValues free + forall txA txB free. + ( HasSynchronousReset txA + , HasDefinedInitialValues txA + , HasSynchronousReset txB + , HasDefinedInitialValues txB + , HasSynchronousReset free + , HasDefinedInitialValues free ) => DutTestFunc txA txB free -> InputFunc txA txB free -> @@ -236,24 +262,23 @@ dutRandomized :: -- Input txB txA -> Proxy (free :: Domain) -> Property - dutRandomized f inputA inputB Proxy = property $ do -- Note that the maximum timeout should be below 'ResetManager.txTimeoutMs' and -- 'ResetManager.rxTimeoutMs'. let genTimeoutMax = Gen.word64 (Range.linear 0 (natToNum @(PeriodToCycles A (Microseconds 500)))) rxStableA <- fromIntegral <$> forAll genTimeoutMax txStableA <- fromIntegral <$> forAll genTimeoutMax - txDoneA <- fromIntegral <$> forAll genTimeoutMax + txDoneA <- fromIntegral <$> forAll genTimeoutMax rxStableB <- fromIntegral <$> forAll genTimeoutMax txStableB <- fromIntegral <$> forAll genTimeoutMax - txDoneB <- fromIntegral <$> forAll genTimeoutMax + txDoneB <- fromIntegral <$> forAll genTimeoutMax -- XXX: Note that a single, static offset is generated. This is not realistic: -- in practise, the offset is random, and "determined" after resetting the -- rx subsystem. We currently don't rely on this behavior, due to the logic -- in "Bittide.Transceiver.WordAlign". - aOffset <- forAll (genIndex Range.constantBounded) - bOffset <- forAll (genIndex Range.constantBounded) + aOffset <- forAll (genIndex Range.constantBounded) + bOffset <- forAll (genIndex Range.constantBounded) -- A cable of 1km "stores" 42 words of 64 bits. In theory these links can be -- assymetric, although they rarely are in practise. @@ -271,19 +296,25 @@ dutRandomized f inputA inputB Proxy = property $ do gthCoreB = gthCoreMock "B" rxStableB txStableB txDoneB bOffset let - (outputA, outputB) = dut - @free @free @txA @txB @RefIsUnused @8 - abDelay - baDelay - resetManagerConfig - gthCoreA - gthCoreB - (clockGen @free) - (resetGen @free) - (clockGen @free) - (resetGen @free) - (inputA outputA) - (inputB outputB) + (outputA, outputB) = + dut + @free + @free + @txA + @txB + @RefIsUnused + @8 + abDelay + baDelay + resetManagerConfig + gthCoreA + gthCoreB + (clockGen @free) + (resetGen @free) + (clockGen @free) + (resetGen @free) + (inputA outputA) + (inputB outputB) f outputA outputB @@ -299,13 +330,13 @@ testUp500ms outputA outputB = linksUp = outputA.linkUp .&&. outputB.linkUp nCycles = fromIntegral (maxBound :: Index (PeriodToCycles Free (Milliseconds 500))) sampledLinksUp = sampleN nCycles linksUp - sampledAfterStable = List.dropWhile (not . snd) (List.zip [(0::Int)..] sampledLinksUp) + sampledAfterStable = List.dropWhile (not . snd) (List.zip [(0 :: Int) ..] sampledLinksUp) -- | Test whether the link is never up within 500 milliseconds testNeitherUp500ms :: DutTestFunc txA txB free testNeitherUp500ms outputA outputB = False === or (sampleN nCycles linksUp) - where + where linksUp = outputA.linkUp .||. outputB.linkUp nCycles = fromIntegral (maxBound :: Index (PeriodToCycles Free (Milliseconds 500))) @@ -313,11 +344,10 @@ testNeitherUp500ms outputA outputB = testNotBothUp500ms :: DutTestFunc txA txB free testNotBothUp500ms outputA outputB = False === or (sampleN nCycles linksUp) - where + where linksUp = (outputA.linkUp .==. pure True) .&&. (outputB.linkUp .==. pure True) nCycles = fromIntegral (maxBound :: Index (PeriodToCycles Free (Milliseconds 500))) - -- Input that applies no (back)pressure on the link noPressureInput :: InputFunc txA txB free noPressureInput _ = Input{dat = complement <$> 0, txReady = pure True, rxReady = pure True} @@ -330,38 +360,44 @@ noTxReadyInput i = (noPressureInput i){txReady = pure False} noRxReadyInput :: InputFunc txA txB free noRxReadyInput i = (noPressureInput i){rxReady = pure False} --- | Check whether handshake works when there is no pressure on the link, --- specialized to 'A', 'A', 'FreeSlow'. +{- | Check whether handshake works when there is no pressure on the link, +specialized to 'A', 'A', 'FreeSlow'. +-} prop_noPressure_A_A_FreeSlow :: Property prop_noPressure_A_A_FreeSlow = dutRandomized @A @A @FreeSlow testUp500ms noPressureInput noPressureInput Proxy --- | Check whether handshake works when there is no pressure on the link, --- specialized to 'A', 'A', 'Free'. +{- | Check whether handshake works when there is no pressure on the link, +specialized to 'A', 'A', 'Free'. +-} prop_noPressure_A_A_Free :: Property prop_noPressure_A_A_Free = dutRandomized @A @A @Free testUp500ms noPressureInput noPressureInput Proxy --- | Check whether handshake works when there is no pressure on the link, --- specialized to 'A', 'A', 'FreeFast'. +{- | Check whether handshake works when there is no pressure on the link, +specialized to 'A', 'A', 'FreeFast'. +-} prop_noPressure_A_A_FreeFast :: Property prop_noPressure_A_A_FreeFast = dutRandomized @A @A @FreeFast testUp500ms noPressureInput noPressureInput Proxy --- | Check whether handshake works when there is no pressure on the link, --- specialized to 'A', 'B', 'Free'. +{- | Check whether handshake works when there is no pressure on the link, +specialized to 'A', 'B', 'Free'. +-} prop_noPressure_A_B_Free :: Property prop_noPressure_A_B_Free = dutRandomized @A @B @Free testUp500ms noPressureInput noPressureInput Proxy --- | Check whether handshake works when there is no pressure on the link, --- specialized to 'B', 'A', 'Free'. +{- | Check whether handshake works when there is no pressure on the link, +specialized to 'B', 'A', 'Free'. +-} prop_noPressure_B_A_Free :: Property prop_noPressure_B_A_Free = dutRandomized @B @A @Free testUp500ms noPressureInput noPressureInput Proxy --- | Check whether neither handshake works when one of the transceivers never --- indicates it's ready to the other. +{- | Check whether neither handshake works when one of the transceivers never +indicates it's ready to the other. +-} prop_noTxReady :: Property prop_noTxReady = dutRandomized @A @A @Free testNeitherUp500ms noPressureInput noTxReadyInput Proxy @@ -371,13 +407,13 @@ prop_noTxReadyFlipped :: Property prop_noTxReadyFlipped = dutRandomized @A @A @Free testNeitherUp500ms noTxReadyInput noPressureInput Proxy --- | Check whether neither node indicates it's up, when it never transitions to --- sending user data. +{- | Check whether neither node indicates it's up, when it never transitions to +sending user data. +-} prop_noRxReady :: Property prop_noRxReady = dutRandomized @A @A @Free testNeitherUp500ms noRxReadyInput noRxReadyInput Proxy - -- TODO: Add tests for actual data transmission. This currently only happens in -- hardware, as we currently don't have the infrastructure to memory-efficiently -- test multi-domain systems in Clash.. @@ -386,23 +422,40 @@ tests :: TestTree tests = -- XXX: The number of tests we run is very low, due to the time it takes to -- execute them. - testGroup "Transceiver" - [ adjustOption (\_ -> HedgehogTestLimit (Just 100)) $ - testGroup "Slow tests" - [ testPropertyNamed "prop_noPressure_A_A_FreeSlow" "prop_noPressure_A_A_FreeSlow" prop_noPressure_A_A_FreeSlow - , testPropertyNamed "prop_noPressure_A_A_Free" "prop_noPressure_A_A_Free" prop_noPressure_A_A_Free - , testPropertyNamed "prop_noPressure_A_A_FreeFast" "prop_noPressure_A_A_FreeFast" prop_noPressure_A_A_FreeFast - , testPropertyNamed "prop_noPressure_A_B_Free" "prop_noPressure_A_B_Free" prop_noPressure_A_B_Free - , testPropertyNamed "prop_noPressure_B_A_Free" "prop_noPressure_B_A_Free" prop_noPressure_B_A_Free - ] - - , adjustOption (\_ -> HedgehogTestLimit (Just 10)) $ - testGroup "Very slow tests" - -- These tests are "very slow" because they cannot exit early on some - -- condition. Instead, they just wait for some deadline, and if they don't - -- see an errornous condition by then, they pass. - [ testPropertyNamed "prop_noTxReady" "prop_noTxReady" prop_noTxReady - , testPropertyNamed "prop_noTxReadyFlipped" "prop_noTxReadyFlipped" prop_noTxReadyFlipped - , testPropertyNamed "prop_noRxReady" "prop_noRxReady" prop_noRxReady - ] + testGroup + "Transceiver" + [ adjustOption (\_ -> HedgehogTestLimit (Just 100)) + $ testGroup + "Slow tests" + [ testPropertyNamed + "prop_noPressure_A_A_FreeSlow" + "prop_noPressure_A_A_FreeSlow" + prop_noPressure_A_A_FreeSlow + , testPropertyNamed + "prop_noPressure_A_A_Free" + "prop_noPressure_A_A_Free" + prop_noPressure_A_A_Free + , testPropertyNamed + "prop_noPressure_A_A_FreeFast" + "prop_noPressure_A_A_FreeFast" + prop_noPressure_A_A_FreeFast + , testPropertyNamed + "prop_noPressure_A_B_Free" + "prop_noPressure_A_B_Free" + prop_noPressure_A_B_Free + , testPropertyNamed + "prop_noPressure_B_A_Free" + "prop_noPressure_B_A_Free" + prop_noPressure_B_A_Free + ] + , adjustOption (\_ -> HedgehogTestLimit (Just 10)) + $ testGroup + "Very slow tests" + -- These tests are "very slow" because they cannot exit early on some + -- condition. Instead, they just wait for some deadline, and if they don't + -- see an errornous condition by then, they pass. + [ testPropertyNamed "prop_noTxReady" "prop_noTxReady" prop_noTxReady + , testPropertyNamed "prop_noTxReadyFlipped" "prop_noTxReadyFlipped" prop_noTxReadyFlipped + , testPropertyNamed "prop_noRxReady" "prop_noRxReady" prop_noRxReady + ] ] diff --git a/bittide/tests/Tests/Transceiver/Prbs.hs b/bittide/tests/Tests/Transceiver/Prbs.hs index c59f2b9a2..63d1d8979 100644 --- a/bittide/tests/Tests/Transceiver/Prbs.hs +++ b/bittide/tests/Tests/Transceiver/Prbs.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,27 +22,29 @@ import qualified Data.List as L import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range - data SomePrbsConfig where SomePrbsConfig :: - KnownNat nBytes => + (KnownNat nBytes) => Prbs.Config polyLength polyTap (8 * nBytes) -> SomePrbsConfig instance Show SomePrbsConfig where show (SomePrbsConfig (Prbs.Config :: Prbs.Config polyLength polyTap (8 * nBytes))) = "SomePrbsConfig (Prbs.Config" - <> "{polyLength=" <> show (snatToNatural (SNat :: SNat polyLength)) - <> ", polyTap=" <> show (snatToNatural (SNat :: SNat polyTap)) - <> ", nBytes=" <> show (snatToNatural (SNat :: SNat nBytes)) + <> "{polyLength=" + <> show (snatToNatural (SNat :: SNat polyLength)) + <> ", polyTap=" + <> show (snatToNatural (SNat :: SNat polyTap)) + <> ", nBytes=" + <> show (snatToNatural (SNat :: SNat nBytes)) <> "})" --- | Generate a 'SomePrbsConfig' such that: --- --- * 1 <= nBits <= (n + 1) --- * 1 <= polyTap <= (n + 1) --- * (polyTap + 1) <= polyLength <= (polyTap + 1 + n + 1) --- +{- | Generate a 'SomePrbsConfig' such that: + +* 1 <= nBits <= (n + 1) +* 1 <= polyTap <= (n + 1) +* (polyTap + 1) <= polyLength <= (polyTap + 1 + n + 1) +-} genSomePrbsConfig :: Natural -> Gen SomePrbsConfig genSomePrbsConfig n = do n0 <- Gen.integral (Range.linear 0 n) @@ -56,7 +57,7 @@ genSomePrbsConfig n = do nBytes = sn0 `addSNat` d1 polyTap = sn1 `addSNat` d1 polyLength = polyTap `addSNat` d1 `addSNat` sn2 - in + in case (nBytes, polyTap, polyLength) of (SNat :: SNat nBytes, SNat :: SNat polyTap, SNat :: SNat polyLength) -> pure $ SomePrbsConfig (Prbs.Config @polyLength @polyTap @(8 * nBytes)) @@ -65,15 +66,15 @@ genSomePrbsConfig n = do checkOk :: Int checkOk = 8 --- | Connect a PRBS generator to a PRBS checker and check that no errors are --- detected after the expected time it takes for the checker to align with the --- generator. +{- | Connect a PRBS generator to a PRBS checker and check that no errors are +detected after the expected time it takes for the checker to align with the +generator. +-} prop_happy :: Property prop_happy = property $ do SomePrbsConfig config@Prbs.Config{} <- forAll (genSomePrbsConfig 100) case config of (Prbs.Config :: Prbs.Config polyLength polyTap nBits) -> do - offset <- forAll (genIndex Range.constantBounded) let resetCycle = 1 @@ -93,8 +94,9 @@ prop_happy = property $ do noiseCounter = register clk rst ena (0 :: Int) (noiseCounter + 1) sendNoise = noiseCounter .<. pure nNoiseCycles noiseOrPrbs = mux sendNoise (fromList (noise <> L.repeat 0)) prbs - noiseOrPrbsDealigned = withClock clk $ - WordAlign.aligner WordAlign.dealignLsbFirst (pure False) (pure offset) noiseOrPrbs + noiseOrPrbsDealigned = + withClock clk + $ WordAlign.aligner WordAlign.dealignLsbFirst (pure False) (pure offset) noiseOrPrbs errors = Prbs.checker clk rst ena config noiseOrPrbsDealigned okAfter = fromIntegral (nNoiseCycles + expectAlignmentAfterNCycles) @@ -108,11 +110,13 @@ prop_happy = property $ do L.take checkOk ok === L.replicate checkOk 0 -- Statistics checks - cover 20 + cover + 20 "nNoiseCycles > expectAlignmentAfterNCycles" (nNoiseCycles > expectAlignmentAfterNCycles) - cover 20 + cover + 20 "nNoiseCycles <= expectAlignmentAfterNCycles" (nNoiseCycles <= expectAlignmentAfterNCycles) @@ -120,9 +124,11 @@ prop_happy = property $ do cover 2 "no errors detected after 3 cycles" allOk -- detect "always pass" tests :: TestTree -tests = testGroup "Prbs" - [ testPropertyNamed "prop_happy" "prop_happy" prop_happy - ] +tests = + testGroup + "Prbs" + [ testPropertyNamed "prop_happy" "prop_happy" prop_happy + ] main :: IO () main = defaultMain tests diff --git a/bittide/tests/Tests/Transceiver/WordAlign.hs b/bittide/tests/Tests/Transceiver/WordAlign.hs index 57eb4f3fa..d1307ebbf 100644 --- a/bittide/tests/Tests/Transceiver/WordAlign.hs +++ b/bittide/tests/Tests/Transceiver/WordAlign.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: 2024 Google LLC -- -- SPDX-License-Identifier: Apache-2.0 - {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} @@ -13,13 +12,13 @@ import Clash.Prelude hiding (someNatVal, words) import Bittide.SharedTypes (Byte) import Clash.Hedgehog.Sized.BitVector (genDefinedBitVector) import Clash.Hedgehog.Sized.Index (genIndex) -import Data.Proxy (Proxy(..)) +import Data.Proxy (Proxy (..)) import GHC.TypeNats (someNatVal) import Hedgehog import Numeric (showHex) import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.Hedgehog import qualified Bittide.Transceiver.WordAlign as WordAlign import qualified Clash.Explicit.Prelude as E @@ -135,8 +134,9 @@ prop_wordAlignFromMsbsLsbFirst = prop_wordAlignFromMsbs WordAlign.alignLsbFirst prop_wordAlignFromMsbsMsbFirst :: Property prop_wordAlignFromMsbsMsbFirst = prop_wordAlignFromMsbs WordAlign.alignMsbFirst WordAlign.dealignMsbFirst --- | Make sure we can recover "user data" after sending alignment bits and freezing --- the offset/alignment. +{- | Make sure we can recover "user data" after sending alignment bits and freezing +the offset/alignment. +-} prop_wordAlignFromMsbs :: (forall n. WordAlign.AlignmentFn n) -> (forall n. WordAlign.AlignmentFn n) -> @@ -146,9 +146,8 @@ prop_wordAlignFromMsbs alignFn dealignFn = property $ do nBytesMinusOne <- forAll $ Gen.integral (Range.linear 0 16) withSomeSNat nBytesMinusOne (go . succSNat) where - -- Worker function that only deals with term level naturals - go :: forall nBytes . (1 <= nBytes) => SNat nBytes -> PropertyT IO () + go :: forall nBytes. (1 <= nBytes) => SNat nBytes -> PropertyT IO () go SNat = leToPlus @1 @nBytes $ do -- How much offset is "inserted" by the "transceiver"s byteOffset <- forAll $ genIndex Range.constantBounded @@ -164,8 +163,8 @@ prop_wordAlignFromMsbs alignFn dealignFn = property $ do -- of the words thereafter. nAlignCycles <- forAll $ Gen.integral (Range.linear 2 16) alignWords <- - fmap (WordAlign.joinMsbs @nBytes @8 WordAlign.alignSymbol) <$> - forAll (Gen.list (Range.singleton nAlignCycles) genDefinedBitVector) + fmap (WordAlign.joinMsbs @nBytes @8 WordAlign.alignSymbol) + <$> forAll (Gen.list (Range.singleton nAlignCycles) genDefinedBitVector) -- Number of cycles to produce data with (potentially) invalid alignment -- bits. We expect to be able to recover these words, because the aligner @@ -182,46 +181,55 @@ prop_wordAlignFromMsbs alignFn dealignFn = property $ do pipelineDepth = 1 freeze = - L.replicate nPreAlignCycles False - <> L.replicate nAlignCycles False - <> L.replicate nPostAlignCycles True + L.replicate nPreAlignCycles False + <> L.replicate nAlignCycles False + <> L.replicate nPostAlignCycles True sampled = - E.sampleN (nCycles + pipelineDepth) - $ WordAlign.alignBytesFromMsbs @nBytes alignFn (E.fromList (freeze <> L.repeat True)) - $ allDealignedWords + E.sampleN (nCycles + pipelineDepth) + $ WordAlign.alignBytesFromMsbs @nBytes alignFn (E.fromList (freeze <> L.repeat True)) + $ allDealignedWords actual = - L.take nPostAlignCycles - $ L.drop (nPreAlignCycles + nAlignCycles + pipelineDepth) - $ sampled + L.take nPostAlignCycles + $ L.drop (nPreAlignCycles + nAlignCycles + pipelineDepth) + $ sampled footnote $ "preAlignWords: " <> show preAlignWords footnote $ "alignWords: " <> show alignWords footnote $ "postAlignWords: " <> show postAlignWords footnote $ "sampled: " <> show sampled - footnote $ "allDealignedWords: " <> show (sampleN (nCycles + pipelineDepth) allDealignedWords) + footnote + $ "allDealignedWords: " + <> show (sampleN (nCycles + pipelineDepth) allDealignedWords) footnote $ "freeze: " <> show freeze postAlignWords === actual tests :: TestTree -tests = testGroup "WordAlign" - [ testCase "case_dealignLsbFirst" case_dealignLsbFirst - , testCase "case_dealignMsbFirst" case_dealignMsbFirst - , testCase "case_alignLsbFirst" case_alignLsbFirst - , testCase "case_alignMsbFirst" case_alignMsbFirst - , testPropertyNamed "prop_alignDealignLsb" "prop_alignDealignLsb" prop_alignDealignLsb - , testPropertyNamed "prop_alignDealignMsb" "prop_alignDealignMsb" prop_alignDealignMsb - , testPropertyNamed "prop_wordAlignFromMsbsLsbFirst" "prop_wordAlignFromMsbsLsbFirst" prop_wordAlignFromMsbsLsbFirst - , testPropertyNamed "prop_wordAlignFromMsbsMsbFirst" "prop_wordAlignFromMsbsMsbFirst" prop_wordAlignFromMsbsMsbFirst - - -- While this works, it also prints the error which is very confusing :-( - -- , expectFail $ testPropertyNamed "prop_alignDealignMsbLsb" "prop_alignDealignMsbLsb" prop_alignDealignMsbLsb - -- , expectFail $ testPropertyNamed "prop_alignDealignLsbMsb" "prop_alignDealignLsbMsb" prop_alignDealignLsbMsb - ] +tests = + testGroup + "WordAlign" + [ testCase "case_dealignLsbFirst" case_dealignLsbFirst + , testCase "case_dealignMsbFirst" case_dealignMsbFirst + , testCase "case_alignLsbFirst" case_alignLsbFirst + , testCase "case_alignMsbFirst" case_alignMsbFirst + , testPropertyNamed "prop_alignDealignLsb" "prop_alignDealignLsb" prop_alignDealignLsb + , testPropertyNamed "prop_alignDealignMsb" "prop_alignDealignMsb" prop_alignDealignMsb + , testPropertyNamed + "prop_wordAlignFromMsbsLsbFirst" + "prop_wordAlignFromMsbsLsbFirst" + prop_wordAlignFromMsbsLsbFirst + , testPropertyNamed + "prop_wordAlignFromMsbsMsbFirst" + "prop_wordAlignFromMsbsMsbFirst" + prop_wordAlignFromMsbsMsbFirst + -- While this works, it also prints the error which is very confusing :-( + -- , expectFail $ testPropertyNamed "prop_alignDealignMsbLsb" "prop_alignDealignMsbLsb" prop_alignDealignMsbLsb + -- , expectFail $ testPropertyNamed "prop_alignDealignLsbMsb" "prop_alignDealignLsbMsb" prop_alignDealignLsbMsb + ] main :: IO () main = - defaultMain $ - adjustOption (const (HedgehogTestLimit (Just 1000))) tests + defaultMain + $ adjustOption (const (HedgehogTestLimit (Just 1000))) tests diff --git a/bittide/tests/Tests/Wishbone.hs b/bittide/tests/Tests/Wishbone.hs index 5bf61a58a..d7677203c 100644 --- a/bittide/tests/Tests/Wishbone.hs +++ b/bittide/tests/Tests/Wishbone.hs @@ -1,30 +1,28 @@ --- SPDX-FileCopyrightText: 2022 Google LLC --- --- SPDX-License-Identifier: Apache-2.0 - -{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} +-- SPDX-FileCopyrightText: 2022 Google LLC +-- +-- SPDX-License-Identifier: Apache-2.0 +{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} {-# OPTIONS_GHC -fplugin Protocols.Plugin #-} -module Tests.Wishbone(tests) where +module Tests.Wishbone (tests) where import Clash.Prelude hiding (sample) import Clash.Hedgehog.Sized.Vector -import Clash.Sized.Vector(unsafeFromList) +import Clash.Sized.Vector (unsafeFromList) import Data.Bifunctor -import Data.Constraint (Dict(Dict)) +import Data.Constraint (Dict (Dict)) import Data.Constraint.Nat.Extra (cancelMulDiv, divWithRemainder) import Data.String import Hedgehog import Hedgehog.Range as Range import Protocols -import Protocols.Df(Data(..)) +import Protocols.Df (Data (..)) import Protocols.Hedgehog import Protocols.Wishbone import Protocols.Wishbone.Standard.Hedgehog (validatorCircuit) @@ -40,17 +38,23 @@ import qualified GHC.TypeNats as TN import qualified Hedgehog.Gen as Gen tests :: TestTree -tests = testGroup "Tests.Wishbone" - [ testPropertyNamed "Reading readData from slaves." "readingSlaves" readingSlaves - , testPropertyNamed "Writing and reading from slaves." "writingSlaves" writingSlaves - , testPropertyNamed "Send and receive bytes via uartWb" "uartWbCircuitTest" uartWbCircuitTest - ] +tests = + testGroup + "Tests.Wishbone" + [ testPropertyNamed "Reading readData from slaves." "readingSlaves" readingSlaves + , testPropertyNamed "Writing and reading from slaves." "writingSlaves" writingSlaves + , testPropertyNamed + "Send and receive bytes via uartWb" + "uartWbCircuitTest" + uartWbCircuitTest + ] -data UartMachineState = ReadStatus | ReadByte | WriteByte | OutputByte (BitVector 8) +data UartMachineState = ReadStatus | ReadByte | WriteByte | OutputByte (BitVector 8) deriving (Generic, NFDataX, Show) --- | A `Circuit` that transforms incoming `Df` transactions into `Wishbone` transactions --- that are compatible with `Bittide.Wishbone.wbToDf`. +{- | A `Circuit` that transforms incoming `Df` transactions into `Wishbone` transactions +that are compatible with `Bittide.Wishbone.wbToDf`. +-} -- .It implements the following state machine: -- 1. Check if there is incoming data available in the `wbToDf` receive fifo, if so, skip to 4. @@ -61,10 +65,10 @@ data UartMachineState = ReadStatus | ReadByte | WriteByte | OutputByte (BitVect -- 6. If there is no data available at the incoming Df interface, go to 1. -- 7. Write data from incoming Df interface to `wbToDf`. uartMachine :: - forall dom addrW . + forall dom addrW. ( HiddenClockResetEnable dom , KnownNat addrW - ) => + ) => Circuit (Df dom (BitVector 8)) (Wishbone dom 'Standard addrW Byte, Df dom (BitVector 8)) @@ -74,34 +78,32 @@ uartMachine = Circuit (second unbundle . mealyB go ReadStatus . second bundle) where (rxEmpty, txFull) = unpack (resize readData) nextState = case (acknowledge, err, (rxEmpty, txFull)) of - (True, False, (False, _)) -> ReadByte + (True, False, (False, _)) -> ReadByte (True, False, (True, False)) -> WriteByte - _ -> ReadStatus - wbOut = (emptyWishboneM2S @32 ){addr = 4, busCycle = True, strobe = True} - + _ -> ReadStatus + wbOut = (emptyWishboneM2S @32){addr = 4, busCycle = True, strobe = True} go ReadByte (_, ~(WishboneS2M{..}, _)) = (nextState, (Ack False, (wbOut, NoData))) where nextState = case (acknowledge, err) of (True, False) -> OutputByte (resize readData) - _ -> ReadByte - wbOut = (emptyWishboneM2S @32 ){addr = 0, busCycle = True, strobe = True} - + _ -> ReadByte + wbOut = (emptyWishboneM2S @32){addr = 0, busCycle = True, strobe = True} go (OutputByte byte) (_, ~(_, Ack dfAck)) = (nextState, (Ack False, (emptyWishboneM2S, Data byte))) where nextState = if dfAck then ReadStatus else (OutputByte byte) - go (WriteByte) (Data dfData, ~(WishboneS2M{..}, _)) = (nextState, (Ack dfAck, (wbOut, NoData))) where (nextState, dfAck) = if acknowledge && not err then (ReadStatus, True) else (WriteByte, False) - wbOut = (emptyWishboneM2S @32 @()) - { addr = 0 - , busCycle = True - , strobe = True - , writeEnable = True - , busSelect = 1 - , writeData = resize dfData - } + wbOut = + (emptyWishboneM2S @32 @()) + { addr = 0 + , busCycle = True + , strobe = True + , writeEnable = True + , busSelect = 1 + , writeData = resize dfData + } go WriteByte (NoData, _) = (ReadStatus, (Ack False, (emptyWishboneM2S, NoData))) -- | Check if we can combine `uartWb` in loopback mode and `uartMachine` to create `id`. @@ -109,38 +111,41 @@ uartWbCircuitTest :: Property uartWbCircuitTest = do let dataGen = Gen.list (Range.linear 0 32) $ genDefinedBitVector @8 - dut :: HiddenClockResetEnable System => Circuit (Df System Byte) (Df System Byte) + dut :: (HiddenClockResetEnable System) => Circuit (Df System Byte) (Df System Byte) dut = circuit $ \dfIn -> do (wb, dfOut) <- uartMachine -< dfIn (uartTx, _status) <- uartWb @System @32 d2 d2 (SNat @6250000) -< (wb, uartTx) idC -< dfOut - expectOptions = defExpectOptions - { eoResetCycles = 15 - , eoDriveEarly = True - } + expectOptions = + defExpectOptions + { eoResetCycles = 15 + , eoDriveEarly = True + } idWithModel expectOptions dataGen id (wcre dut) --- | Generates a 'MemoryMap' for 'singleMasterInterconnect' for a specific number --- of slaves. +{- | Generates a 'MemoryMap' for 'singleMasterInterconnect' for a specific number +of slaves. +-} genConfig :: - forall nSlaves . + forall nSlaves. (1 <= nSlaves) => SNat nSlaves -> Gen (MemoryMap nSlaves) genConfig nSlaves@SNat = - unsafeFromList . L.take (snatToNum nSlaves) <$> Gen.shuffle [0..] + unsafeFromList . L.take (snatToNum nSlaves) <$> Gen.shuffle [0 ..] --- | Creates a memory map with 'simpleSlave' devices and a list of read addresses and checks --- if the correct 'simpleSlave' responds to the read operation. Reading outside of a 'simpleSlave' its --- range should return an error. +{- | Creates a memory map with 'simpleSlave' devices and a list of read addresses and checks +if the correct 'simpleSlave' responds to the read operation. Reading outside of a 'simpleSlave' its +range should return an error. +-} readingSlaves :: Property readingSlaves = property $ do devices <- forAll $ Gen.enum 2 16 - case TN.someNatVal (devices - 1)of - SomeNat (succSNat . snatProxy -> devices0@SNat) -> - case compareSNat (clogBaseSNat d2 devices0) d32 of - SNatLE -> runTest devices0 - _ -> errorX "readingSlaves: number of devices can't be represented with 32 bits." + case TN.someNatVal (devices - 1) of + SomeNat (succSNat . snatProxy -> devices0@SNat) -> + case compareSNat (clogBaseSNat d2 devices0) d32 of + SNatLE -> runTest devices0 + _ -> errorX "readingSlaves: number of devices can't be represented with 32 bits." where runTest devices = do config <- forAll $ genConfig @_ devices @@ -165,44 +170,61 @@ readingSlaves = property $ do topEntity config ranges masterIn = toMaster where - slaves = withClockResetEnable @System clockGen resetGen enableGen $ - simpleSlave <$> ranges <*> config <*> unbundle toSlaves - (toMaster, toSlaves) = withClockResetEnable clockGen resetGen enableGen - singleMasterInterconnect' config masterIn $ bundle slaves + slaves = + withClockResetEnable @System clockGen resetGen enableGen + $ simpleSlave + <$> ranges + <*> config + <*> unbundle toSlaves + (toMaster, toSlaves) = + withClockResetEnable + clockGen + resetGen + enableGen + singleMasterInterconnect' + config + masterIn + $ bundle slaves getExpected :: - forall nSlaves . - ( KnownNat nSlaves, 1 <= nSlaves, BitSize (Unsigned (CLog 2 nSlaves)) <= 32 - , BitSize (Unsigned (CLog 2 nSlaves)) <= 32) => + forall nSlaves. + ( KnownNat nSlaves + , 1 <= nSlaves + , BitSize (Unsigned (CLog 2 nSlaves)) <= 32 + , BitSize (Unsigned (CLog 2 nSlaves)) <= 32 + ) => Vec nSlaves (Unsigned (CLog 2 nSlaves)) -> Vec nSlaves (BitVector (32 - BitSize (Unsigned (CLog 2 nSlaves)))) -> WishboneM2S 32 (Regs (Unsigned (CLog 2 nSlaves)) 8) (Unsigned (CLog 2 nSlaves)) -> WishboneS2M (Unsigned (CLog 2 nSlaves)) getExpected config ranges WishboneM2S{..} | not commAttempt = emptyWishboneS2M - | Nothing <- maybeIndex = emptyWishboneS2M{err=True} - | Just index <- maybeIndex, not (inRange index) = emptyWishboneS2M{err=True} - | otherwise = (emptyWishboneS2M @(Unsigned (CLog 2 nSlaves))) - {acknowledge=True, readData=unpack indexBV} + | Nothing <- maybeIndex = emptyWishboneS2M{err = True} + | Just index <- maybeIndex, not (inRange index) = emptyWishboneS2M{err = True} + | otherwise = + (emptyWishboneS2M @(Unsigned (CLog 2 nSlaves))) + { acknowledge = True + , readData = unpack indexBV + } where commAttempt = busCycle && strobe maybeIndex = elemIndex (unpack indexBV) config (indexBV :: BitVector (CLog 2 nSlaves), restAddr) = split addr inRange index = restAddr <= (ranges !! index) --- | Creates a memory map with 'simpleSlave' devices and a list of write addresses and checks --- that if we 'simpleSlave' responds to the read operation. Reading outside of a 'simpleSlave' its --- range should return an err. +{- | Creates a memory map with 'simpleSlave' devices and a list of write addresses and checks +that if we 'simpleSlave' responds to the read operation. Reading outside of a 'simpleSlave' its +range should return an err. +-} writingSlaves :: Property writingSlaves = property $ do devices <- forAll $ Gen.enum 1 16 - case TN.someNatVal (devices - 1)of - SomeNat (succSNat . snatProxy -> devices0) -> - case compareSNat (clogBaseSNat d2 devices0 ) d32 of - SNatLE -> runTest devices0 - _ -> errorX "readingSlaves: number of devices can't be represented with 32 bits." + case TN.someNatVal (devices - 1) of + SomeNat (succSNat . snatProxy -> devices0) -> + case compareSNat (clogBaseSNat d2 devices0) d32 of + SNatLE -> runTest devices0 + _ -> errorX "readingSlaves: number of devices can't be represented with 32 bits." where - runTest devices = do config <- forAll $ genConfig @_ devices nrOfWrites <- forAll $ Gen.enum 1 32 @@ -210,7 +232,7 @@ writingSlaves = property $ do writeAddresses <- forAll $ Gen.list nrOfWritesRange genDefinedBitVector ranges <- forAll $ genVec genDefinedBitVector let - topEntityInput = L.concatMap wbWriteThenRead writeAddresses <> [emptyWishboneM2S ] + topEntityInput = L.concatMap wbWriteThenRead writeAddresses <> [emptyWishboneM2S] simLength = L.length topEntityInput simOut = simulateN simLength (topEntity config ranges) topEntityInput realTransactions = wbToTransaction topEntityInput simOut @@ -227,29 +249,48 @@ writingSlaves = property $ do topEntity config ranges masterIn = toMaster where - slaves = withClockResetEnable @System clockGen resetGen enableGen $ - simpleSlave <$> ranges <*> ranges <*> unbundle toSlaves - (toMaster, toSlaves) = withClockResetEnable clockGen resetGen enableGen - singleMasterInterconnect' config masterIn $ bundle slaves + slaves = + withClockResetEnable @System clockGen resetGen enableGen + $ simpleSlave + <$> ranges + <*> ranges + <*> unbundle toSlaves + (toMaster, toSlaves) = + withClockResetEnable + clockGen + resetGen + enableGen + singleMasterInterconnect' + config + masterIn + $ bundle slaves wbWriteThenRead a = [wbWrite a (resize a), wbRead a] getExpected :: - forall nSlaves . - ( KnownNat nSlaves, 1 <= nSlaves, BitSize (Unsigned (CLog 2 nSlaves)) <= 32 - , BitSize (Unsigned (CLog 2 nSlaves)) <= 32) => + forall nSlaves. + ( KnownNat nSlaves + , 1 <= nSlaves + , BitSize (Unsigned (CLog 2 nSlaves)) <= 32 + , BitSize (Unsigned (CLog 2 nSlaves)) <= 32 + ) => Vec nSlaves (Unsigned (CLog 2 nSlaves)) -> Vec nSlaves (BitVector (32 - BitSize (Unsigned (CLog 2 nSlaves)))) -> - WishboneM2S 32 (DivRU (32 - BitSize (Unsigned (CLog 2 nSlaves))) 8) + WishboneM2S + 32 + (DivRU (32 - BitSize (Unsigned (CLog 2 nSlaves))) 8) (BitVector (32 - BitSize (Unsigned (CLog 2 nSlaves)))) -> WishboneS2M (BitVector (32 - BitSize (Unsigned (CLog 2 nSlaves)))) getExpected config ranges WishboneM2S{..} | not commAttempt = emptyWishboneS2M - | Nothing <- maybeIndex = emptyWishboneS2M{err=True} - | Just index <- maybeIndex, not (inRange index) = emptyWishboneS2M{err=True} - | writeEnable = emptyWishboneS2M{acknowledge=True} - | otherwise = (emptyWishboneS2M @(Unsigned (CLog 2 nSlaves))) - {acknowledge=True, readData=restAddr} + | Nothing <- maybeIndex = emptyWishboneS2M{err = True} + | Just index <- maybeIndex, not (inRange index) = emptyWishboneS2M{err = True} + | writeEnable = emptyWishboneS2M{acknowledge = True} + | otherwise = + (emptyWishboneS2M @(Unsigned (CLog 2 nSlaves))) + { acknowledge = True + , readData = restAddr + } where commAttempt = busCycle && strobe maybeIndex = elemIndex (unpack indexBV) config @@ -257,39 +298,41 @@ writingSlaves = property $ do inRange index = restAddr <= (ranges !! index) -- | transforms an address to a 'WishboneM2S' read operation. -wbRead - :: forall addressWidth a - . (KnownNat addressWidth, NFDataX a, KnownNat (BitSize a)) - => BitVector addressWidth - -> WishboneM2S addressWidth (Regs a 8) a +wbRead :: + forall addressWidth a. + (KnownNat addressWidth, NFDataX a, KnownNat (BitSize a)) => + BitVector addressWidth -> + WishboneM2S addressWidth (Regs a 8) a wbRead address = case cancelMulDiv @(Regs a 8) @8 of Dict -> (emptyWishboneM2S @addressWidth) + { addr = address + , strobe = True + , busCycle = True + , busSelect = maxBound + } + +{- | transforms an address to a 'WishboneM2S' write operation that writes the given address +to the given address. +-} +wbWrite :: + forall addressWidth a. + (KnownNat addressWidth, NFDataX a, KnownNat (BitSize a)) => + BitVector addressWidth -> + a -> + WishboneM2S addressWidth (Regs a 8) a +wbWrite address a = + (emptyWishboneM2S @addressWidth @a) { addr = address , strobe = True , busCycle = True + , writeData = a + , writeEnable = True , busSelect = maxBound } --- | transforms an address to a 'WishboneM2S' write operation that writes the given address --- to the given address. -wbWrite - :: forall addressWidth a - . (KnownNat addressWidth, NFDataX a, KnownNat (BitSize a)) - => BitVector addressWidth - -> a - -> WishboneM2S addressWidth (Regs a 8) a -wbWrite address a = (emptyWishboneM2S @addressWidth @a) - { addr = address - , strobe = True - , busCycle = True - , writeData = a - , writeEnable = True - , busSelect = maxBound - } - simpleSlave' :: - forall dom aw a . + forall dom aw a. (HiddenClockResetEnable dom, KnownNat aw, NFDataX a) => BitVector aw -> a -> @@ -300,22 +343,24 @@ simpleSlave' range readDataInit = go readData1 WishboneM2S{..} = (readData2, (emptyWishboneS2M @a){readData, acknowledge, err}) where - masterActive = busCycle && strobe - addrInRange = addr <= range - acknowledge = masterActive && addrInRange - err = masterActive && not addrInRange - writeOp = acknowledge && writeEnable - readData2 | writeOp = writeData - | otherwise = readData1 - readData | writeOp = writeData - | otherwise = readData1 - + masterActive = busCycle && strobe + addrInRange = addr <= range + acknowledge = masterActive && addrInRange + err = masterActive && not addrInRange + writeOp = acknowledge && writeEnable + readData2 + | writeOp = writeData + | otherwise = readData1 + readData + | writeOp = writeData + | otherwise = readData1 --- | Simple wishbone slave that responds to addresses [0..range], it responds by returning --- a stored value (initialized by readData0), which can be overwritten by the wishbone bus. --- any read/write attempt to an address outside of the supplied range sets the err signal. +{- | Simple wishbone slave that responds to addresses [0..range], it responds by returning +a stored value (initialized by readData0), which can be overwritten by the wishbone bus. +any read/write attempt to an address outside of the supplied range sets the err signal. +-} simpleSlave :: - forall dom aw a . + forall dom aw a. (HiddenClockResetEnable dom, KnownNat aw, BitPack a, NFDataX a, ShowX a) => BitVector aw -> a -> diff --git a/bittide/tests/UnitTests.hs b/bittide/tests/UnitTests.hs index 618470af1..3ffa2c904 100644 --- a/bittide/tests/UnitTests.hs +++ b/bittide/tests/UnitTests.hs @@ -28,41 +28,46 @@ import qualified Tests.Transceiver.WordAlign import qualified Tests.Wishbone tests :: TestTree -tests = testGroup "Unittests" - [ Tests.Axi4.tests - , Tests.Calendar.tests - , Tests.ClockControl.Si539xSpi.tests - , Tests.DoubleBufferedRam.tests - , Tests.ElasticBuffer.tests - , Tests.Link.tests - , Tests.ProcessingElement.ReadElf.tests - , Tests.ScatterGather.tests - , Tests.StabilityChecker.tests - , Tests.Switch.tests - , Tests.Transceiver.tests - , Tests.Transceiver.Prbs.tests - , Tests.Transceiver.WordAlign.tests - , Tests.Wishbone.tests - , Tests.Axi4.Generators.tests - , Tests.Axi4.Properties.tests - , Tests.Haxioms.tests - ] +tests = + testGroup + "Unittests" + [ Tests.Axi4.tests + , Tests.Calendar.tests + , Tests.ClockControl.Si539xSpi.tests + , Tests.DoubleBufferedRam.tests + , Tests.ElasticBuffer.tests + , Tests.Link.tests + , Tests.ProcessingElement.ReadElf.tests + , Tests.ScatterGather.tests + , Tests.StabilityChecker.tests + , Tests.Switch.tests + , Tests.Transceiver.tests + , Tests.Transceiver.Prbs.tests + , Tests.Transceiver.WordAlign.tests + , Tests.Wishbone.tests + , Tests.Axi4.Generators.tests + , Tests.Axi4.Properties.tests + , Tests.Haxioms.tests + ] --- | Default number of tests is 100, which is too low for our (complicated) --- state machinery. +{- | Default number of tests is 100, which is too low for our (complicated) +state machinery. +-} setDefaultHedgehogTestLimit :: HedgehogTestLimit -> HedgehogTestLimit setDefaultHedgehogTestLimit (HedgehogTestLimit Nothing) = HedgehogTestLimit (Just 1000) setDefaultHedgehogTestLimit opt = opt --- | Hedgehog seemingly gets stuck in an infinite loop when shrinking - probably --- due to the way our generators depend on each other. We limit the number of --- shrinks to 100. +{- | Hedgehog seemingly gets stuck in an infinite loop when shrinking - probably +due to the way our generators depend on each other. We limit the number of +shrinks to 100. +-} setDefaultHedgehogShrinkLimit :: HedgehogShrinkLimit -> HedgehogShrinkLimit setDefaultHedgehogShrinkLimit (HedgehogShrinkLimit Nothing) = HedgehogShrinkLimit (Just 100) setDefaultHedgehogShrinkLimit opt = opt main :: IO () -main = defaultMain - $ adjustOption setDefaultHedgehogTestLimit - $ adjustOption setDefaultHedgehogShrinkLimit - $ tests +main = + defaultMain $ + adjustOption setDefaultHedgehogTestLimit $ + adjustOption setDefaultHedgehogShrinkLimit $ + tests diff --git a/bittide/tests/doctests.hs b/bittide/tests/doctests.hs index 601ef48af..17e8f5f57 100644 --- a/bittide/tests/doctests.hs +++ b/bittide/tests/doctests.hs @@ -11,4 +11,4 @@ main :: IO () main = do -- We use Nix to setup tooling, not to provide GHC packages so we need to set --no-nix args <- getArgs - mainFromCabal "bittide" ("--no-nix":args) + mainFromCabal "bittide" ("--no-nix" : args) From d49b63ef2f87ea4cb7b12100239ed476afaab6a3 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Fri, 9 Aug 2024 11:00:03 +0200 Subject: [PATCH 4/4] Ignore formatting commit for blame --- .git-blame-ignore-revs | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 .git-blame-ignore-revs diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 000000000..fa343ac5a --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,4 @@ +# SPDX-FileCopyrightText: 2024 Google LLC +# +# SPDX-License-Identifier: CC0-1.0 +a4e4b4b8833acdc0d1f9c488d01e827a04598d98