├── .ci ├── apply_settings.sh ├── build_docs.sh ├── cabal.project.local.in ├── test_cabal.sh ├── test_stack.sh └── test_whitespace.sh ├── .git-blame-ignore-revs ├── .github ├── scripts │ └── all_check.py └── workflows │ └── ci.yml ├── .gitignore ├── .vscode └── settings.json ├── LICENSE ├── README.md ├── cabal.project ├── clash-protocols-base ├── LICENSE ├── Setup.hs ├── clash-protocols-base.cabal └── src │ └── Protocols │ ├── Plugin.hs │ └── Plugin │ ├── Cpp.hs │ ├── Internal.hs │ ├── TH.hs │ ├── TaggedBundle.hs │ ├── TaggedBundle │ └── TH.hs │ ├── Types.hs │ ├── Units.hs │ └── Units │ └── TH.hs ├── clash-protocols ├── LICENSE ├── Setup.hs ├── clash-protocols.cabal ├── src │ ├── Clash │ │ └── Sized │ │ │ └── Vector │ │ │ └── Extra.hs │ ├── Data │ │ ├── Constraint │ │ │ └── Nat │ │ │ │ └── Extra.hs │ │ └── Maybe │ │ │ └── Extra.hs │ ├── Protocols.hs │ ├── Protocols │ │ ├── Avalon │ │ │ ├── MemMap.hs │ │ │ └── Stream.hs │ │ ├── Axi4 │ │ │ ├── Common.hs │ │ │ ├── ReadAddress.hs │ │ │ ├── ReadData.hs │ │ │ ├── Stream.hs │ │ │ ├── WriteAddress.hs │ │ │ ├── WriteData.hs │ │ │ └── WriteResponse.hs │ │ ├── Df.hs │ │ ├── DfConv.hs │ │ ├── Hedgehog.hs │ │ ├── Hedgehog │ │ │ ├── Internal.hs │ │ │ └── Types.hs │ │ ├── Idle.hs │ │ ├── Internal.hs │ │ ├── Internal │ │ │ ├── TH.hs │ │ │ └── Types.hs │ │ ├── PacketStream.hs │ │ ├── PacketStream │ │ │ ├── AsyncFifo.hs │ │ │ ├── Base.hs │ │ │ ├── Converters.hs │ │ │ ├── Depacketizers.hs │ │ │ ├── Hedgehog.hs │ │ │ ├── PacketFifo.hs │ │ │ ├── Packetizers.hs │ │ │ ├── Padding.hs │ │ │ └── Routing.hs │ │ ├── Vec.hs │ │ ├── Wishbone.hs │ │ └── Wishbone │ │ │ ├── Standard.hs │ │ │ └── Standard │ │ │ └── Hedgehog.hs │ └── Test │ │ └── Tasty │ │ └── Hedgehog │ │ └── Extra.hs └── tests │ ├── Tests │ ├── Haxioms.hs │ ├── Protocols.hs │ └── Protocols │ │ ├── Avalon.hs │ │ ├── Axi4.hs │ │ ├── Df.hs │ │ ├── DfConv.hs │ │ ├── PacketStream.hs │ │ ├── PacketStream │ │ ├── AsyncFifo.hs │ │ ├── Base.hs │ │ ├── Converters.hs │ │ ├── Depacketizers.hs │ │ ├── PacketFifo.hs │ │ ├── Packetizers.hs │ │ ├── Padding.hs │ │ └── Routing.hs │ │ ├── Plugin.hs │ │ ├── Vec.hs │ │ └── Wishbone.hs │ ├── Util.hs │ ├── doctests.hs │ └── unittests.hs ├── default.nix ├── format.sh ├── fourmolu.yaml ├── hie.yaml ├── nix ├── aarch64-reloc.patch ├── nixpkgs.nix ├── sources.json └── sources.nix ├── release.nix ├── shell.nix └── stack.yaml /.ci/apply_settings.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -uo pipefail 4 | 5 | if [[ "$check_haddock" != @(True|False) ]]; then 6 | echo "check_haddock: Expected True or False, got \"$check_haddock\"" >&2 7 | exit 1 8 | fi 9 | sed <.ci/cabal.project.local.in >cabal.project.local " 10 | s/__CHECK_HADDOCK__/$check_haddock/ 11 | s/__CLASH_VERSION__/$clash_version/" 12 | -------------------------------------------------------------------------------- /.ci/build_docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -xeou pipefail 3 | 4 | cabal v2-haddock all |& tee haddock_log 5 | 6 | set +e 7 | 8 | suppressed_warnings=( 9 | 'Consider exporting it together with its parent(s) for code clarity.' 10 | ) 11 | 12 | grep -v -e "${suppressed_warnings[@]}" haddock_log |& tee haddock_filtered 13 | 14 | if grep -q "Missing documentation" haddock_filtered; then 15 | echo -e "\e[1m\e[31mMissing documentation! Scroll up for full log.\e[0m" 16 | grep --color=always -n -C 5 "Missing documentation" haddock_filtered 17 | exit 1 18 | fi 19 | 20 | if grep -q "If you qualify the identifier, haddock can try to link it anyway" haddock_filtered; then 21 | echo -e "\e[1m\e[31mIdentifier out of scope! Scroll up for full log.\e[0m" 22 | grep --color=always -n -C 5 "If you qualify the identifier, haddock can try to link it anyway" haddock_filtered 23 | exit 1 24 | fi 25 | 26 | if grep -q "could not find link destinations for" haddock_filtered; then 27 | echo -e "\e[1m\e[31mAn identifier could not be linked! Scroll up for full log.\e[0m" 28 | grep --color=always -n -C 5 "could not find link destinations for" haddock_filtered 29 | exit 1 30 | fi 31 | 32 | if grep -E -q "^Warning:" haddock_filtered; then 33 | echo -e "\e[1m\e[31mAn unknown warning occured. Scroll up for full log.\e[0m" 34 | grep --color=always -n -C 5 -E "^Warning:" haddock_filtered 35 | exit 1 36 | fi 37 | 38 | # Copy documention to docs/ 39 | ln -s "$(dirname "$(tail -n1 haddock_filtered)")" docs 40 | -------------------------------------------------------------------------------- /.ci/cabal.project.local.in: -------------------------------------------------------------------------------- 1 | package * 2 | documentation: __CHECK_HADDOCK__ 3 | 4 | package clash-protocols-base 5 | documentation: False 6 | ghc-options: -Werror 7 | 8 | package clash-protocols 9 | documentation: False 10 | ghc-options: -Werror 11 | 12 | constraints: 13 | clash-prelude == __CLASH_VERSION__ 14 | -------------------------------------------------------------------------------- /.ci/test_cabal.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -xeou pipefail 3 | 4 | cabal v2-run unittests --enable-tests 5 | cabal v2-run doctests --enable-tests 6 | cabal v2-sdist all 7 | -------------------------------------------------------------------------------- /.ci/test_stack.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -xeou pipefail 3 | 4 | stack --version 5 | stack build 6 | stack test 7 | -------------------------------------------------------------------------------- /.ci/test_whitespace.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -xou pipefail 3 | 4 | grep \ 5 | -E ' $' -n -r . \ 6 | --include=*.{hs,hs-boot,sh,cabal,md,yml} \ 7 | --exclude-dir=dist-newstyle --exclude-dir=deps 8 | if [[ $? == 0 ]]; then 9 | echo "EOL whitespace detected. See ^" 10 | exit 1; 11 | fi 12 | -------------------------------------------------------------------------------- /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | 8eb89807b15f622e70b25f0eb18f8de6404dac23 2 | -------------------------------------------------------------------------------- /.github/scripts/all_check.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | """ 3 | Makes sure: 4 | 5 | * All jobs are listed in the 'all' job 6 | * Only existing tests are listed 7 | 8 | """ 9 | 10 | # SPDX-FileCopyrightText: 2022 Google LLC 11 | # 12 | # SPDX-License-Identifier: Apache-2.0 13 | 14 | import sys 15 | import yaml 16 | 17 | CI_PATH = ".github/workflows/ci.yml" 18 | ALL_TEST = "all" 19 | 20 | def main(): 21 | ci_yml_fp = open(CI_PATH, "r") 22 | ci_yml_parsed = yaml.load(ci_yml_fp, Loader=yaml.FullLoader) 23 | 24 | all_jobs = set(ci_yml_parsed['jobs'].keys()) - {ALL_TEST} 25 | all_needs = set(ci_yml_parsed["jobs"][ALL_TEST]["needs"]) 26 | 27 | if all_jobs - all_needs: 28 | sys.exit(f"Not all jobs mentioned in {ALL_TEST}.needs: {all_jobs - all_needs}") 29 | 30 | if all_needs - all_jobs: 31 | sys.exit(f"Non-existing jobs found in {ALL_TEST}.needs: {all_needs - all_jobs}") 32 | 33 | 34 | if __name__ == '__main__': 35 | main() 36 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on all pull requests and pushes/merges to main branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [main] 8 | workflow_dispatch: 9 | 10 | 11 | concurrency: 12 | group: ${{ github.head_ref || github.run_id }} 13 | cancel-in-progress: true 14 | 15 | jobs: 16 | stack: 17 | name: Stack tests 18 | runs-on: ubuntu-latest 19 | steps: 20 | - name: Checkout 21 | uses: actions/checkout@v4 22 | 23 | - name: Setup Stack / GHC 24 | uses: haskell-actions/setup@v2 25 | with: 26 | ghc-version: '9.8.4' 27 | cabal-version: '3.14.1.1' 28 | enable-stack: true 29 | stack-version: 'latest' 30 | 31 | # Ask Stack to use system GHC instead of installing its own copy 32 | - name: Use system GHC 33 | run: | 34 | stack config set system-ghc --global true 35 | 36 | - name: Restore cached dependencies 37 | uses: actions/cache/restore@v4 38 | id: cache 39 | with: 40 | path: ~/.stack 41 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ github.ref }}-${{ github.sha }} 42 | restore-keys: | 43 | ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ github.ref }}-${{ github.sha }} 44 | ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ github.ref }}- 45 | ${{ runner.os }}-ghc-${{ matrix.ghc }}- 46 | 47 | - name: Install dependencies 48 | run: stack build --test --only-dependencies 49 | 50 | # Cache dependencies already at this point, so that we do not have to 51 | # rebuild them should the subsequent steps fail 52 | - name: Save cached dependencies 53 | uses: actions/cache/save@v4 54 | # Trying to save over an existing cache gives distracting 55 | # "Warning: Cache save failed." since they are immutable 56 | if: ${{ steps.cache.outputs.cache-hit != 'true' }} 57 | with: 58 | path: ~/.stack 59 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ github.ref }}-${{ github.sha }} 60 | 61 | - name: Test with Stack 62 | run: | 63 | .ci/test_stack.sh 64 | 65 | cabal: 66 | name: Cabal tests - ghc ${{ matrix.ghc }} / clash ${{ matrix.clash }} / doc ${{ matrix.check_haddock }} 67 | runs-on: ${{ matrix.os }} 68 | strategy: 69 | fail-fast: false 70 | matrix: 71 | os: [ubuntu-latest] 72 | clash: 73 | - "1.8.2" 74 | cabal: 75 | - "3.14.1.1" 76 | ghc: 77 | - "9.2.8" 78 | - "9.4.8" 79 | - "9.8.4" 80 | - "9.10.1" 81 | include: 82 | - check_haddock: "False" 83 | - ghc: "9.6.6" 84 | check_haddock: "True" 85 | os: "ubuntu-latest" 86 | clash: "1.8.2" 87 | cabal: "3.14.1.1" 88 | 89 | env: 90 | check_haddock: ${{ matrix.check_haddock }} 91 | clash_version: ${{ matrix.clash }} 92 | 93 | steps: 94 | - name: Checkout 95 | uses: actions/checkout@v4 96 | 97 | - name: Setup Haskell 98 | uses: haskell-actions/setup@v2 99 | id: setup-haskell-cabal 100 | with: 101 | ghc-version: ${{ matrix.ghc }} 102 | cabal-version: ${{ matrix.cabal }} 103 | 104 | - name: Use CI specific settings 105 | run: | 106 | .ci/apply_settings.sh 107 | 108 | - name: Setup CI 109 | run: | 110 | cabal v2-freeze 111 | mv cabal.project.freeze frozen 112 | 113 | - name: Restore cached dependencies 114 | uses: actions/cache/restore@v4 115 | id: cache 116 | env: 117 | key: 118 | ${{ runner.os }}-ghc-${{ matrix.ghc }}-cabal-${{ 119 | steps.setup-haskell.outputs.cabal-version }}${{ 120 | matrix.project-variant }} 121 | with: 122 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 123 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ matrix.clash }}-${{ hashFiles('frozen') }} 124 | restore-keys: | 125 | ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ matrix.clash }}-${{ hashFiles('frozen') }} 126 | ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ matrix.clash }}- 127 | ${{ runner.os }}-ghc-${{ matrix.ghc }}- 128 | 129 | - name: Install dependencies 130 | run: cabal v2-build all --enable-tests --only-dependencies 131 | 132 | # Cache dependencies already at this point, so that we do not have to 133 | # rebuild them should the subsequent steps fail 134 | - name: Save cached dependencies 135 | uses: actions/cache/save@v4 136 | # Trying to save over an existing cache gives distracting 137 | # "Warning: Cache save failed." since they are immutable 138 | if: ${{ steps.cache.outputs.cache-hit != 'true' }} 139 | with: 140 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 141 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ matrix.clash }}-${{ hashFiles('frozen') }} 142 | 143 | - name: Build 144 | run: | 145 | cabal v2-build all --enable-tests 146 | 147 | - name: Test 148 | run: | 149 | .ci/test_cabal.sh 150 | 151 | - name: Documentation 152 | if: ${{ matrix.check_haddock == 'True' }} 153 | run: | 154 | .ci/build_docs.sh 155 | 156 | fourmolu: 157 | runs-on: ubuntu-latest 158 | steps: 159 | # Note that you must checkout your code before running haskell-actions/run-fourmolu 160 | - uses: actions/checkout@v3 161 | - uses: haskell-actions/run-fourmolu@v9 162 | with: 163 | version: "0.14.0.0" 164 | pattern: | 165 | **/*.hs 166 | !clash-protocols-base/src/Protocols/Plugin/Cpp.hs 167 | 168 | linting: 169 | name: Source code linting 170 | runs-on: ubuntu-latest 171 | steps: 172 | - name: Checkout 173 | uses: actions/checkout@v4 174 | 175 | - name: Whitespace 176 | run: | 177 | .ci/test_whitespace.sh 178 | 179 | # Mandatory check on GitHub 180 | all: 181 | name: All jobs finished 182 | if: always() 183 | needs: [ 184 | cabal, 185 | fourmolu, 186 | linting, 187 | stack, 188 | ] 189 | runs-on: ubuntu-22.04 190 | steps: 191 | - name: Checkout 192 | uses: actions/checkout@v4 193 | 194 | - name: Check dependencies for failures 195 | run: | 196 | # Test all dependencies for success/failure 197 | set -x 198 | success="${{ contains(needs.*.result, 'success') }}" 199 | fail="${{ contains(needs.*.result, 'failure') }}" 200 | set +x 201 | 202 | # Test whether success/fail variables contain sane values 203 | if [[ "${success}" != "true" && "${success}" != "false" ]]; then exit 1; fi 204 | if [[ "${fail}" != "true" && "${fail}" != "false" ]]; then exit 1; fi 205 | 206 | # We want to fail if one or more dependencies fail. For safety, we introduce 207 | # a second check: if no dependencies succeeded something weird is going on. 208 | if [[ "${fail}" == "true" || "${success}" == "false" ]]; then 209 | echo "One or more dependency failed, or no dependency succeeded." 210 | exit 1 211 | fi 212 | 213 | - name: Install dependencies 214 | run: | 215 | sudo apt-get update 216 | sudo apt-get -y install python3-yaml 217 | 218 | - name: Check that the 'all' job depends on all other jobs 219 | run: | 220 | .github/scripts/all_check.py 221 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .stack-work/ 4 | cabal-dev 5 | /cabal.project.local 6 | .ghc.environment.* 7 | *.o 8 | *.o-boot 9 | *.hi 10 | *.hi-boot 11 | *.po 12 | *.po-boot 13 | *.p_o 14 | *.p_o-boot 15 | *.chi 16 | *.chs.h 17 | *.dyn_o 18 | *.dyn_o-boot 19 | *.dyn_hi 20 | *.dyn_hi-boot 21 | .virtualenv 22 | .hpc 23 | .hsenv 24 | .cabal-sandbox/ 25 | cabal.sandbox.config 26 | cabal.config 27 | *.prof 28 | *.aux 29 | *.hp 30 | *.bin 31 | *.log 32 | *.tar.gz 33 | stack.yaml.lock 34 | 35 | *~ 36 | *.DS_Store 37 | 38 | # IntelliJ 39 | /.idea 40 | *.iml 41 | 42 | # HDL directories often created during development cycle 43 | /vhdl 44 | /verilog 45 | /systemverilog 46 | 47 | log 48 | 49 | # Created by .ci/build_docs.sh 50 | /docs 51 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "files.exclude": { 3 | "**/*.dyn_hi": true, 4 | "**/*.dyn_o": true, 5 | "**/*.hi": true, 6 | "**/*.o": true, 7 | "dist-newstyle": true, 8 | ".stack-work": true, 9 | ".ghc.environment.*": true 10 | }, 11 | "files.trimTrailingWhitespace": true, 12 | "files.insertFinalNewline": true, 13 | "editor.tabSize": 2, 14 | "[haskell]": { 15 | "editor.formatOnSave": false 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Martijn Bastiaan 2 | 2024, QBayLogic B.V. 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./clash-protocols-base 3 | ./clash-protocols 4 | 5 | tests: True 6 | 7 | package clash-prelude 8 | -- 'large-tuples' generates tuple instances for various classes up to the 9 | -- GHC imposed maximum of 62 elements. This severely slows down compiling 10 | -- Clash, and triggers Template Haskell bugs on Windows. Hence, we disable 11 | -- it by default. This will be the default for Clash >=1.4. 12 | flags: -large-tuples 13 | 14 | source-repository-package 15 | type: git 16 | location: https://github.com/cchalmers/circuit-notation.git 17 | tag: 564769c52aa05b90f81bbc898b7af7087d96613d 18 | 19 | package clash-protocols-base 20 | -- Reduces compile times by ~20% 21 | ghc-options: +RTS -qn4 -A128M -RTS -j4 22 | 23 | -- Workaround for Haddock/CPP #if issues https://github.com/haskell/haddock/issues/1382 24 | haddock-options: --optghc="-optP -P" 25 | 26 | -- Don't pollute docs with large tuple instances 27 | haddock-options: --optghc=-DHADDOCK_ONLY 28 | 29 | package clash-protocols 30 | -- Reduces compile times by ~20% 31 | ghc-options: +RTS -qn4 -A128M -RTS -j4 32 | 33 | -- Workaround for Haddock/CPP #if issues https://github.com/haskell/haddock/issues/1382 34 | haddock-options: --optghc="-optP -P" 35 | 36 | -- Don't pollute docs with large tuple instances 37 | haddock-options: --optghc=-DHADDOCK_ONLY 38 | -------------------------------------------------------------------------------- /clash-protocols-base/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Martijn Bastiaan 2 | 2024, QBayLogic B.V. 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /clash-protocols-base/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Prelude 3 | 4 | main :: IO () 5 | main = defaultMain 6 | -------------------------------------------------------------------------------- /clash-protocols-base/clash-protocols-base.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: clash-protocols-base 3 | synopsis: a battery-included library for (dataflow) protocols 4 | Homepage: https://gitlab.com/martijnbastiaan/clash-protocols 5 | version: 0.1 6 | category: Hardware 7 | license: BSD-2-Clause 8 | license-file: LICENSE 9 | author: Martijn Bastiaan, QBayLogic B.V. 10 | maintainer: Martijn Bastiaan 11 | 12 | flag large-tuples 13 | description: 14 | Generate instances for classes such as `Units` and `TaggedBundle` for tuples 15 | up to and including 62 elements - the GHC imposed maximum. Note that this 16 | greatly increases compile times for `clash-protocols-base`. 17 | default: False 18 | manual: True 19 | 20 | common common-options 21 | default-extensions: 22 | CPP 23 | DataKinds 24 | DefaultSignatures 25 | DeriveAnyClass 26 | DerivingStrategies 27 | LambdaCase 28 | NoStarIsType 29 | OverloadedRecordDot 30 | TupleSections 31 | TypeFamilies 32 | ViewPatterns 33 | 34 | -- TemplateHaskell is used to support convenience functions such as 35 | -- 'listToVecTH' and 'bLit'. 36 | TemplateHaskell 37 | QuasiQuotes 38 | 39 | -- Prelude isn't imported by default as Clash offers Clash.Prelude 40 | -- NoImplicitPrelude 41 | ghc-options: 42 | -Wall -Wcompat 43 | 44 | -- Plugins to support type-level constraint solving on naturals 45 | -fplugin GHC.TypeLits.Extra.Solver 46 | -fplugin GHC.TypeLits.Normalise 47 | -fplugin GHC.TypeLits.KnownNat.Solver 48 | 49 | -- Clash needs access to the source code in compiled modules 50 | -fexpose-all-unfoldings 51 | 52 | -- Worker wrappers introduce unstable names for functions that might have 53 | -- blackboxes attached for them. You can disable this, but be sure to add 54 | -- a no-specialize pragma to every function with a blackbox. 55 | -fno-worker-wrapper 56 | 57 | default-language: GHC2021 58 | build-depends: 59 | base >= 4.16.1.0, 60 | Cabal, 61 | 62 | clash-prelude >= 1.8.1 && < 1.10, 63 | ghc-typelits-natnormalise, 64 | ghc-typelits-extra, 65 | ghc-typelits-knownnat 66 | 67 | custom-setup 68 | setup-depends: 69 | base >= 4.16 && <5, 70 | Cabal >= 2.4, 71 | 72 | library 73 | import: common-options 74 | hs-source-dirs: src 75 | 76 | if flag(large-tuples) 77 | CPP-Options: -DLARGE_TUPLES 78 | 79 | build-depends: 80 | , circuit-notation 81 | , deepseq 82 | , extra 83 | , ghc >= 8.7 && < 9.11 84 | , hashable 85 | , tagged 86 | , template-haskell 87 | 88 | exposed-modules: 89 | Protocols.Plugin 90 | Protocols.Plugin.Cpp 91 | Protocols.Plugin.Internal 92 | Protocols.Plugin.TaggedBundle 93 | Protocols.Plugin.TaggedBundle.TH 94 | Protocols.Plugin.TH 95 | Protocols.Plugin.Units 96 | Protocols.Plugin.Units.TH 97 | 98 | other-modules: 99 | Protocols.Plugin.Types 100 | 101 | default-language: GHC2021 102 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {- | 4 | A GHC source plugin providing a DSL for writing Circuit components. Credits to 5 | @circuit-notation@ at . 6 | -} 7 | module Protocols.Plugin ( 8 | -- * Circuit types 9 | Circuit (..), 10 | Protocol (..), 11 | 12 | -- * clash-prelude related types 13 | CSignal, 14 | 15 | -- * plugin functions 16 | plugin, 17 | circuit, 18 | (-<), 19 | ) where 20 | 21 | -- base 22 | import Prelude 23 | 24 | -- clash-prelude 25 | import Clash.Explicit.Prelude qualified as C 26 | 27 | -- clash-protocols 28 | import Protocols.Plugin.Cpp 29 | import Protocols.Plugin.Internal 30 | import Protocols.Plugin.TH 31 | import Protocols.Plugin.TaggedBundle 32 | import Protocols.Plugin.Types 33 | import Protocols.Plugin.Units 34 | 35 | -- circuit-notation 36 | import CircuitNotation qualified as CN 37 | 38 | -- tagged 39 | import Data.Tagged 40 | 41 | -- ghc 42 | import GHC.Plugins qualified as GHC 43 | 44 | instance Protocol () where 45 | type Fwd () = () 46 | type Bwd () = () 47 | 48 | {- | __NB__: The documentation only shows instances up to /3/-tuples. By 49 | default, instances up to and including /12/-tuples will exist. If the flag 50 | @large-tuples@ is set instances up to the GHC imposed limit will exist. The 51 | GHC imposed limit is either 62 or 64 depending on the GHC version. 52 | -} 53 | instance Protocol (a, b) where 54 | type Fwd (a, b) = (Fwd a, Fwd b) 55 | type Bwd (a, b) = (Bwd a, Bwd b) 56 | 57 | -- Generate n-tuple instances, where n > 2 58 | protocolTupleInstances 3 maxTupleSize 59 | 60 | instance (C.KnownNat n) => Protocol (C.Vec n a) where 61 | type Fwd (C.Vec n a) = C.Vec n (Fwd a) 62 | type Bwd (C.Vec n a) = C.Vec n (Bwd a) 63 | 64 | -- XXX: Type families with Signals on LHS are currently broken on Clash: 65 | instance Protocol (CSignal dom a) where 66 | type Fwd (CSignal dom a) = C.Signal dom a 67 | type Bwd (CSignal dom a) = C.Signal dom () 68 | 69 | -- | @circuit-notation@ plugin repurposed for "Protocols". 70 | plugin :: GHC.Plugin 71 | plugin = 72 | CN.mkPlugin $ 73 | CN.ExternalNames 74 | { CN.circuitCon = CN.thName 'TaggedCircuit 75 | , CN.fwdAndBwdTypes = \case 76 | CN.Fwd -> CN.thName ''Fwd 77 | CN.Bwd -> CN.thName ''Bwd 78 | , CN.fwdBwdCon = CN.thName '(,) 79 | , CN.runCircuitName = CN.thName 'taggedCircuit 80 | , CN.tagBundlePat = CN.thName 'TaggedBundle 81 | , CN.tagName = CN.thName 'Tagged 82 | , CN.tagTName = CN.thName ''Tagged 83 | , CN.trivialBwd = CN.thName 'units 84 | , CN.consPat = CN.thName '(:>!) 85 | } 86 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/Cpp.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (C) 2019 , Myrtle Software Ltd, 3 | 2023 , QBayLogic B.V., 4 | 2024 , Google LLC 5 | License : BSD2 (see the file LICENSE) 6 | Maintainer : QBayLogic B.V. 7 | 8 | Compile-time dependent constants. Inspired by @clash-prelude@'s @Clash.CPP@. 9 | -} 10 | 11 | 12 | {-# OPTIONS_HADDOCK hide #-} 13 | 14 | module Protocols.Plugin.Cpp 15 | ( maxTupleSize 16 | , haddockOnly 17 | ) where 18 | 19 | #ifndef MAX_TUPLE_SIZE 20 | #ifdef LARGE_TUPLES 21 | 22 | import GHC.Settings.Constants (mAX_TUPLE_SIZE) 23 | 24 | #define MAX_TUPLE_SIZE (fromIntegral mAX_TUPLE_SIZE) 25 | 26 | #else 27 | #ifdef HADDOCK_ONLY 28 | #define MAX_TUPLE_SIZE 3 29 | #else 30 | #define MAX_TUPLE_SIZE 12 31 | #endif 32 | #endif 33 | #endif 34 | 35 | maxTupleSize :: Num a => a 36 | maxTupleSize = MAX_TUPLE_SIZE 37 | 38 | haddockOnly :: Bool 39 | #ifdef HADDOCK_ONLY 40 | haddockOnly = True 41 | #else 42 | haddockOnly = False 43 | #endif 44 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | module Protocols.Plugin.Internal where 6 | 7 | import Clash.Explicit.Prelude 8 | 9 | import Data.Tagged 10 | import GHC.Base (Any) 11 | import Protocols.Plugin.Types 12 | 13 | {- | Picked up by "Protocols.Plugin" to process protocol DSL. See 14 | "Protocols.Plugin" for more information. 15 | -} 16 | circuit :: Any 17 | circuit = 18 | error "'circuit' called: did you forget to enable \"Protocols.Plugin\"?" 19 | 20 | {- | Picked up by "Protocols.Plugin" to tie circuits together. See 21 | "Protocols.Plugin" for more information. 22 | -} 23 | (-<) :: Any 24 | (-<) = 25 | error "(-<) called: did you forget to enable \"Protocols.Plugin\"?" 26 | 27 | {- | Convenience type alias. A circuit where all parts are decorated with a 28 | tag, referring to the @a@ and @b@ in its main signature. This is (indirectly) 29 | used by the plugin to help GHC's type inference. 30 | -} 31 | type TaggedCircuitT a b = 32 | (Tagged a (Fwd a), Tagged b (Bwd b)) -> 33 | (Tagged a (Bwd a), Tagged b (Fwd b)) 34 | 35 | -- | Remove tags from a tagged "Circuit", leaving just a "Circuit". 36 | unTaggedCircuit :: TaggedCircuitT a b -> Circuit a b 37 | unTaggedCircuit f = Circuit $ \(aFwd, bBwd) -> 38 | let (Tagged aBwd, Tagged bFwd) = f (Tagged aFwd, Tagged bBwd) 39 | in (aBwd, bFwd) 40 | 41 | -- | Add tags to a "Circuit", making a "TaggedCircuitT". 42 | taggedCircuit :: Circuit a b -> TaggedCircuitT a b 43 | taggedCircuit (Circuit c) (aFwd, bBwd) = 44 | let (aBwd, bFwd) = c (unTagged aFwd, unTagged bBwd) 45 | in (Tagged aBwd, Tagged bFwd) 46 | 47 | -- | Convenience pattern for 'unTaggedCircuit' and 'taggedCircuit'. 48 | pattern TaggedCircuit :: TaggedCircuitT a b -> Circuit a b 49 | pattern TaggedCircuit f <- (taggedCircuit -> f) 50 | where 51 | TaggedCircuit f = unTaggedCircuit f 52 | 53 | {- | Unsafe version of ':>'. Will fail if applied to empty vectors. This is used to 54 | work around spurious incomplete pattern match warnings generated in newer GHC 55 | versions. 56 | -} 57 | pattern (:>!) :: a -> Vec n a -> Vec (n + 1) a 58 | pattern (:>!) x xs <- (\ys -> (head ys, tail ys) -> (x, xs)) 59 | 60 | {-# COMPLETE (:>!) #-} 61 | infixr 5 :>! 62 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/TH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module Protocols.Plugin.TH where 4 | 5 | import Language.Haskell.TH 6 | 7 | appTs :: Q Type -> [Q Type] -> Q Type 8 | appTs = foldl appT 9 | 10 | -- | Generate @Protocol@ instances for n-tuples 11 | protocolTupleInstances :: Int -> Int -> Q [Dec] 12 | protocolTupleInstances n m = mapM protocolTupleInstance [n .. m] 13 | 14 | protocolTupleInstance :: Int -> Q Dec 15 | protocolTupleInstance n = 16 | instanceD 17 | (pure []) -- context 18 | (protocolConT `appT` tup) -- head 19 | [mkTyInst fwdConName, mkTyInst bwdConName] -- body 20 | where 21 | fwdConName = mkName "Fwd" 22 | bwdConName = mkName "Bwd" 23 | protocolConT = conT (mkName "Protocol") 24 | 25 | tyVars :: [TypeQ] 26 | tyVars = map (varT . mkName . ('a' :) . show) [1 .. n] 27 | 28 | tup = tupleT n `appTs` tyVars 29 | 30 | mkTyInst :: Name -> DecQ 31 | mkTyInst con = 32 | tySynInstD $ tySynEqn Nothing lhs rhs 33 | where 34 | lhs, rhs :: TypeQ 35 | lhs = conT con `appT` tup 36 | rhs = tupleT n `appTs` map (conT con `appT`) tyVars 37 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/TaggedBundle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE TypeFamilyDependencies #-} 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | -- For debugging TH: 6 | -- {-# OPTIONS_GHC -ddump-splices #-} 7 | 8 | module Protocols.Plugin.TaggedBundle where 9 | 10 | import Clash.Explicit.Prelude 11 | 12 | import Protocols.Plugin.Cpp (maxTupleSize) 13 | import Protocols.Plugin.TaggedBundle.TH (taggedBundleTupleInstances) 14 | 15 | import Data.Tagged 16 | 17 | {- | A bundle class that retains an attached phantom type @t@. I.e., a crossing 18 | between "Tagged" and "Bundle". 19 | -} 20 | class TaggedBundle t a where 21 | type TaggedUnbundled t a = res | res -> t a 22 | taggedBundle :: TaggedUnbundled t a -> Tagged t a 23 | taggedUnbundle :: Tagged t a -> TaggedUnbundled t a 24 | 25 | instance TaggedBundle () () where 26 | type TaggedUnbundled () () = () 27 | taggedBundle = Tagged 28 | taggedUnbundle = unTagged 29 | 30 | instance TaggedBundle (Vec n t) (Vec n a) where 31 | type TaggedUnbundled (Vec n t) (Vec n a) = Vec n (Tagged t a) 32 | taggedBundle = Tagged . fmap unTagged 33 | taggedUnbundle = fmap Tagged . unTagged 34 | 35 | {- | A convenience pattern that bundles and unbundles. Can be used as an alternative 36 | to using @ViewPatterns@. I.e., the following: 37 | 38 | > myFunction (taggedUnbundle -> ..) 39 | 40 | can be written as: 41 | 42 | > myFunction (TaggedBundle ..) 43 | 44 | Is mostly used by "Protocols.Plugin". 45 | -} 46 | pattern TaggedBundle :: (TaggedBundle t a) => TaggedUnbundled t a -> Tagged t a 47 | pattern TaggedBundle a <- (taggedUnbundle -> a) 48 | where 49 | TaggedBundle a = taggedBundle a 50 | 51 | {-# COMPLETE TaggedBundle #-} 52 | 53 | {- | __NB__: The documentation only shows instances up to /3/-tuples. By 54 | default, instances up to and including /12/-tuples will exist. If the flag 55 | @large-tuples@ is set instances up to the GHC imposed limit will exist. The 56 | GHC imposed limit is either 62 or 64 depending on the GHC version. 57 | -} 58 | instance TaggedBundle (t1, t2) (a1, a2) where 59 | type TaggedUnbundled (t1, t2) (a1, a2) = (Tagged t1 a1, Tagged t2 a2) 60 | taggedBundle (Tagged a1, Tagged a2) = Tagged (a1, a2) 61 | taggedUnbundle (Tagged (a1, a2)) = (Tagged a1, Tagged a2) 62 | 63 | -- Generate n-tuple instances, where n > 2 64 | taggedBundleTupleInstances maxTupleSize 65 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/TaggedBundle/TH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module Protocols.Plugin.TaggedBundle.TH where 4 | 5 | import Data.Tagged 6 | import Language.Haskell.TH 7 | 8 | appTs :: Q Type -> [Q Type] -> Q Type 9 | appTs = foldl appT 10 | 11 | tupT :: [Q Type] -> Q Type 12 | tupT tyArgs = tupleT (length tyArgs) `appTs` tyArgs 13 | 14 | taggedBundleTupleInstances :: Int -> Q [Dec] 15 | taggedBundleTupleInstances n = mapM taggedBundleTupleInstance [3 .. n] 16 | 17 | taggedBundleTupleInstance :: Int -> Q Dec 18 | taggedBundleTupleInstance n = 19 | instanceD 20 | -- No superclasses 21 | (pure []) 22 | -- Head 23 | ( taggedBundleCon 24 | `appT` (tupleT n `appTs` tagTyVars) 25 | `appT` (tupleT n `appTs` tyVars) 26 | ) 27 | -- Implementation 28 | [ tySynInstD (tySynEqn Nothing aTypeLhs aTypeRhs) 29 | , funD taggedBundleFunName [clause [bundlePat] (normalB bundleImpl) []] 30 | , funD taggedUnbundleFunName [clause [unbundlePat] (normalB unbundleImpl) []] 31 | ] 32 | where 33 | -- associated type 34 | taggedUnbundledCon = conT (mkName "TaggedUnbundled") 35 | taggedBundleCon = conT (mkName "TaggedBundle") 36 | aTypeLhs = taggedUnbundledCon `appT` tupT tagTyVars `appT` tupT tyVars 37 | aTypeRhs = tupT (zipWith mkTaggedTy tagTyVars tyVars) 38 | mkTaggedTy ta a = conT ''Tagged `appT` ta `appT` a 39 | 40 | -- bundle 41 | taggedBundleFunName = mkName "taggedBundle" 42 | bundlePat = tupP (map (conP 'Tagged . pure . varP) varNames) 43 | bundleImpl = conE 'Tagged `appE` tupE vars 44 | 45 | -- unbundle 46 | taggedUnbundleFunName = mkName "taggedUnbundle" 47 | unbundlePat = conP 'Tagged [tupP (map varP varNames)] 48 | unbundleImpl = tupE [conE 'Tagged `appE` v | v <- vars] 49 | 50 | -- shared 51 | tagTyVars = map (varT . mkName . ('t' :) . show) [1 .. n] 52 | tyVars = map varT varNames 53 | vars = map varE varNames 54 | varNames = map (mkName . ('a' :) . show) [1 .. n] 55 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RoleAnnotations #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | {- | 5 | These class definitions are needed to be able to write Template Haskell quotes 6 | for instances. They are defined separately to avoid import loops. 7 | 8 | This module is not exported; the classes and their (orphan) instances are 9 | exported elsewhere. 10 | -} 11 | module Protocols.Plugin.Types where 12 | 13 | import Clash.Signal 14 | import Data.Kind (Type) 15 | 16 | -- | A protocol describes the in- and outputs of one side of a 'Circuit'. 17 | class Protocol a where 18 | -- | Sender to receiver type family. See 'Circuit' for an explanation on the 19 | -- existence of 'Fwd'. 20 | type Fwd (a :: Type) 21 | 22 | -- | Receiver to sender type family. See 'Circuit' for an explanation on the 23 | -- existence of 'Bwd'. 24 | type Bwd (a :: Type) 25 | 26 | {- | A /Circuit/, in its most general form, corresponds to a component with two 27 | pairs of an input and output. As a diagram: 28 | 29 | @ 30 | Circuit a b 31 | 32 | +-----------+ 33 | Fwd a | | Fwd b 34 | +------->+ +--------> 35 | | | 36 | | | 37 | Bwd a | | Bwd b 38 | <--------+ +<-------+ 39 | | | 40 | +-----------+ 41 | @ 42 | 43 | The first pair, @(Fwd a, Bwd a)@ can be thought of the data sent to and from 44 | the component on the left hand side of this circuit. For this pair, @Fwd a@ 45 | is the data sent from the circuit on the left hand side (not pictured), while 46 | @Bwd a@ is the data sent to the left hand side from the current circuit. 47 | 48 | Similarly, the second pair, @(Fwd b, Bwd)@, can be thought of as the data 49 | sent to and from the right hand side of this circuit. In this case, @Fwd b@ 50 | is the data sent from the current circuit to the one on the right hand side, 51 | while @Bwd b@ is the data received from the right hand side. 52 | 53 | In Haskell terms, we would say this is simply a function taking two inputs, 54 | @Fwd a@ and @Bwd b@, yielding a pair of outputs @Fwd b@ and @Bwd a@. This is 55 | in fact exactly its definition: 56 | 57 | @ 58 | newtype Circuit a b = 59 | Circuit ( (Fwd a, Bwd b) -> (Bwd a, Fwd b) ) 60 | @ 61 | 62 | Note that the type parameters /a/ and /b/ don't directly correspond to the 63 | types of the inputs and outputs of this function. Instead, the type families 64 | @Fwd@ and @Bwd@ decide this. The type parameters can be thought of as 65 | deciders for what /protocol/ the left hand side and right hand side must 66 | speak. 67 | 68 | Let's make it a bit more concrete by building such a protocol. For this 69 | example, we'd like to build a protocol that sends data to a circuit, while 70 | allowing the circuit to signal whether it processed the sent data or not. Similarly, 71 | we'd like the sender to be able to indicate that it doesn't have any data to 72 | send. These kind of protocols fall under the umbrella of "dataflow" protocols, 73 | so lets call it /DataFlowSimple/ or /Df/ for short: 74 | 75 | @ 76 | data Df (dom :: Domain) (a :: Type) 77 | @ 78 | 79 | We're only going to use it on the type level, so we won't need any 80 | constructors for this datatype. The first type parameter indicates the 81 | synthesis domain the protocol will use. This is the same /dom/ as used in 82 | /Signal dom a/. The second type indicates what data the protocol needs to 83 | send. Again, this is similar to the /a/ in /Signal dom a/. 84 | 85 | As said previously, we'd like the sender to either send /no data/ or 86 | /some data/. We can capture this in a /Maybe/. 87 | 88 | On the way back, we'd like to either acknowledge or not acknowledge sent 89 | data. Similar to /Bool/ we define: 90 | 91 | @ 92 | newtype Ack = Ack Bool 93 | @ 94 | 95 | With these three definitions we're ready to make an instance for /Fwd/ and 96 | /Bwd/: 97 | 98 | @ 99 | instance Protocol (Df dom a) where 100 | type Fwd (Df dom a) = Signal dom (Maybe a) 101 | type Bwd (Df dom a) = Signal dom Ack 102 | @ 103 | 104 | Having defined all this, we can take a look at /Circuit/ once more: now 105 | instantiated with our types. The following: 106 | 107 | @ 108 | f :: Circuit (Df dom a) (Df dom b) 109 | @ 110 | 111 | ..now corresponds to the following protocol: 112 | 113 | @ 114 | +-----------+ 115 | Signal dom (Maybe a) | | Signal dom (Maybe b) 116 | +------------------------>+ +-------------------------> 117 | | | 118 | | | 119 | Signal dom Ack | | Signal dom Ack 120 | <-------------------------+ +<------------------------+ 121 | | | 122 | +-----------+ 123 | @ 124 | 125 | There's a number of advantages over manually writing out these function 126 | types: 127 | 128 | 1. It reduces syntactical noise in type signatures 129 | 130 | 2. It eliminates the need for manually routing acknowledgement lines 131 | -} 132 | newtype Circuit a b 133 | = Circuit ((Fwd a, Bwd b) -> (Bwd a, Fwd b)) 134 | 135 | {- | Circuit protocol with /Signal dom a/ in its forward direction, and 136 | /()/ in its backward direction. Convenient for exposing protocol 137 | internals, or simply for undirectional streams. 138 | Note: 'CSignal' exists to work around [issue 760](https://github.com/clash-lang/clash-compiler/issues/760) 139 | in Clash, where type families with 'Signal' on the LHS are broken. 140 | -} 141 | data CSignal (dom :: Domain) (a :: Type) 142 | 143 | type role CSignal nominal representational 144 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/Units.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | -- For debugging TH: 5 | -- {-# OPTIONS_GHC -ddump-splices #-} 6 | 7 | module Protocols.Plugin.Units where 8 | 9 | import Clash.Explicit.Prelude 10 | 11 | import Protocols.Plugin.Cpp (maxTupleSize) 12 | import Protocols.Plugin.Units.TH (unitsTupleInstances) 13 | 14 | {- | Utilities for zero-width types. Is used by "Protocols.Plugin" to drive \"trivial\" 15 | backwards channels. 16 | -} 17 | class Units a where 18 | -- | Only inhabitant of type @a@. 19 | units :: a 20 | 21 | instance Units () where 22 | units = () 23 | 24 | instance Units (Signed 0) where 25 | units = 0 26 | 27 | instance Units (Unsigned 0) where 28 | units = 0 29 | 30 | instance Units (BitVector 0) where 31 | units = 0 32 | 33 | instance Units (Index 0) where 34 | units = 0 35 | 36 | instance Units (Index 1) where 37 | units = 0 38 | 39 | instance (Units a) => Units (Signal dom a) where 40 | units = pure units 41 | 42 | instance (Units a, KnownNat n) => Units (Vec n a) where 43 | units = repeat units 44 | 45 | {- | __NB__: The documentation only shows instances up to /3/-tuples. By 46 | default, instances up to and including /12/-tuples will exist. If the flag 47 | @large-tuples@ is set instances up to the GHC imposed limit will exist. The 48 | GHC imposed limit is either 62 or 64 depending on the GHC version. 49 | -} 50 | instance (Units a1, Units a2) => Units (a1, a2) where 51 | units = (units, units) 52 | 53 | -- Generate n-tuple instances, where n > 2 54 | unitsTupleInstances maxTupleSize 55 | -------------------------------------------------------------------------------- /clash-protocols-base/src/Protocols/Plugin/Units/TH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module Protocols.Plugin.Units.TH (unitsTupleInstances) where 4 | 5 | import Language.Haskell.TH 6 | 7 | appTs :: Q Type -> [Q Type] -> Q Type 8 | appTs = foldl appT 9 | 10 | unitsTupleInstances :: Int -> Q [Dec] 11 | unitsTupleInstances n = mapM unitsTupleInstance [3 .. n] 12 | 13 | unitsTupleInstance :: Int -> Q Dec 14 | unitsTupleInstance n = 15 | instanceD 16 | (mapM (\v -> unitsConT `appT` v) tyVars) -- context 17 | (unitsConT `appT` (tupleT n `appTs` tyVars)) -- head 18 | [funD unitsFunName [clause [] (normalB (tupE [unitsFun | _ <- tyVars])) []]] -- impl 19 | where 20 | unitsFun = varE unitsFunName 21 | unitsFunName = mkName "units" 22 | unitsConT = conT (mkName "Units") 23 | tyVars = map (varT . mkName . ('a' :) . show) [1 .. n] 24 | -------------------------------------------------------------------------------- /clash-protocols/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Martijn Bastiaan 2 | 2024, QBayLogic B.V. 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /clash-protocols/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Extra.Doctest (defaultMainWithDoctests) 2 | import Prelude 3 | 4 | main :: IO () 5 | main = defaultMainWithDoctests "doctests" 6 | -------------------------------------------------------------------------------- /clash-protocols/clash-protocols.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: clash-protocols 3 | synopsis: a battery-included library for (dataflow) protocols 4 | Homepage: https://gitlab.com/martijnbastiaan/clash-protocols 5 | version: 0.1 6 | category: Hardware 7 | license: BSD-2-Clause 8 | license-file: LICENSE 9 | author: Martijn Bastiaan, QBayLogic B.V. 10 | maintainer: Martijn Bastiaan 11 | description: 12 | Suggested reading order: 13 | . 14 | * 'Protocols' + README.md 15 | * 'Protocols.Df' 16 | * 'Protocols.Plugin' 17 | * 'Protocols.Hedgehog' 18 | 19 | data-files: 20 | src/Protocols/Hedgehog.hs 21 | src/Protocols/Hedgehog/*.hs 22 | 23 | flag large-tuples 24 | description: 25 | Generate instances for classes such as `Units` and `TaggedBundle` for tuples 26 | up to and including 62 elements - the GHC imposed maximum. Note that this 27 | greatly increases compile times for `clash-protocols`. 28 | default: False 29 | manual: True 30 | 31 | common common-options 32 | default-extensions: 33 | CPP 34 | DataKinds 35 | DefaultSignatures 36 | DeriveAnyClass 37 | OverloadedRecordDot 38 | DerivingStrategies 39 | LambdaCase 40 | NoStarIsType 41 | StandaloneDeriving 42 | TupleSections 43 | TypeApplications 44 | TypeFamilies 45 | TypeOperators 46 | ViewPatterns 47 | 48 | -- TemplateHaskell is used to support convenience functions such as 49 | -- 'listToVecTH' and 'bLit'. 50 | TemplateHaskell 51 | QuasiQuotes 52 | 53 | -- Prelude isn't imported by default as Clash offers Clash.Prelude 54 | -- NoImplicitPrelude 55 | ghc-options: 56 | -Wall -Wcompat 57 | 58 | -- Plugins to support type-level constraint solving on naturals 59 | -fplugin GHC.TypeLits.Extra.Solver 60 | -fplugin GHC.TypeLits.Normalise 61 | -fplugin GHC.TypeLits.KnownNat.Solver 62 | 63 | -- Clash needs access to the source code in compiled modules 64 | -fexpose-all-unfoldings 65 | 66 | -- Worker wrappers introduce unstable names for functions that might have 67 | -- blackboxes attached for them. You can disable this, but be sure to add 68 | -- a no-specialize pragma to every function with a blackbox. 69 | -fno-worker-wrapper 70 | 71 | default-language: GHC2021 72 | build-depends: 73 | base >= 4.16.1.0, 74 | Cabal, 75 | 76 | clash-prelude >= 1.8.1 && < 1.10, 77 | ghc-typelits-natnormalise, 78 | ghc-typelits-extra, 79 | ghc-typelits-knownnat 80 | 81 | custom-setup 82 | setup-depends: 83 | base >= 4.16 && <5, 84 | Cabal >= 2.4, 85 | cabal-doctest >= 1.0.1 && <1.1 86 | 87 | library 88 | import: common-options 89 | hs-source-dirs: src 90 | 91 | if flag(large-tuples) 92 | CPP-Options: -DLARGE_TUPLES 93 | 94 | build-depends: 95 | , clash-protocols-base 96 | , circuit-notation 97 | , clash-prelude-hedgehog 98 | , constraints 99 | , data-default ^>= 0.7.1.1 100 | , deepseq 101 | , extra 102 | , hashable 103 | , hedgehog >= 1.0.2 104 | , lifted-async 105 | , mtl 106 | , pretty-show 107 | , strict-tuple 108 | , tagged 109 | , template-haskell 110 | 111 | -- To be removed; we need 'Test.Tasty.Hedgehog.Extra' to fix upstream issues 112 | , tasty >= 1.2 && < 1.5 113 | , tasty-hedgehog >= 1.2 114 | , string-interpolate 115 | 116 | exposed-modules: 117 | Protocols 118 | Protocols.Avalon.MemMap 119 | Protocols.Avalon.Stream 120 | Protocols.Axi4.Common 121 | Protocols.Axi4.ReadAddress 122 | Protocols.Axi4.ReadData 123 | Protocols.Axi4.Stream 124 | Protocols.Axi4.WriteAddress 125 | Protocols.Axi4.WriteData 126 | Protocols.Axi4.WriteResponse 127 | Protocols.PacketStream 128 | Protocols.PacketStream.Base 129 | Protocols.PacketStream.AsyncFifo 130 | Protocols.PacketStream.Converters 131 | Protocols.PacketStream.Depacketizers 132 | Protocols.PacketStream.Hedgehog 133 | Protocols.PacketStream.PacketFifo 134 | Protocols.PacketStream.Packetizers 135 | Protocols.PacketStream.Padding 136 | Protocols.PacketStream.Routing 137 | Protocols.Df 138 | Protocols.DfConv 139 | Protocols.Hedgehog 140 | Protocols.Hedgehog.Internal 141 | Protocols.Idle 142 | Protocols.Internal 143 | Protocols.Internal.TH 144 | Protocols.Vec 145 | Protocols.Wishbone 146 | Protocols.Wishbone.Standard 147 | Protocols.Wishbone.Standard.Hedgehog 148 | 149 | -- 'testProperty' is broken upstream, it reports wrong test names 150 | -- TODO: test / upstream ^ 151 | Test.Tasty.Hedgehog.Extra 152 | 153 | reexported-modules: 154 | Protocols.Plugin 155 | 156 | autogen-modules: Paths_clash_protocols 157 | 158 | other-modules: 159 | Data.Constraint.Nat.Extra 160 | Data.Maybe.Extra 161 | Clash.Sized.Vector.Extra 162 | Paths_clash_protocols 163 | Protocols.Hedgehog.Types 164 | Protocols.Internal.Types 165 | 166 | default-language: GHC2021 167 | 168 | test-suite unittests 169 | import: common-options 170 | hs-source-dirs: tests 171 | type: exitcode-stdio-1.0 172 | ghc-options: -threaded -with-rtsopts=-N 173 | main-is: unittests.hs 174 | other-modules: 175 | Tests.Haxioms 176 | Tests.Protocols 177 | Tests.Protocols.Df 178 | Tests.Protocols.DfConv 179 | Tests.Protocols.Avalon 180 | Tests.Protocols.Axi4 181 | Tests.Protocols.Plugin 182 | Tests.Protocols.Vec 183 | Tests.Protocols.Wishbone 184 | Tests.Protocols.PacketStream 185 | Tests.Protocols.PacketStream.AsyncFifo 186 | Tests.Protocols.PacketStream.Base 187 | Tests.Protocols.PacketStream.Converters 188 | Tests.Protocols.PacketStream.Depacketizers 189 | Tests.Protocols.PacketStream.Packetizers 190 | Tests.Protocols.PacketStream.PacketFifo 191 | Tests.Protocols.PacketStream.Padding 192 | Tests.Protocols.PacketStream.Routing 193 | 194 | Util 195 | 196 | build-depends: 197 | string-interpolate, 198 | clash-protocols-base, 199 | clash-protocols, 200 | clash-prelude-hedgehog, 201 | unordered-containers, 202 | deepseq, 203 | extra, 204 | hashable, 205 | hedgehog, 206 | strict-tuple, 207 | tasty >= 1.2 && < 1.5, 208 | tasty-hedgehog >= 1.2, 209 | tasty-th, 210 | tasty-hunit 211 | 212 | test-suite doctests 213 | import: common-options 214 | type: exitcode-stdio-1.0 215 | default-language: GHC2021 216 | main-is: doctests.hs 217 | hs-source-dirs: tests 218 | 219 | build-depends: 220 | base, 221 | clash-protocols-base, 222 | clash-protocols, 223 | process, 224 | doctest 225 | -------------------------------------------------------------------------------- /clash-protocols/src/Clash/Sized/Vector/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Clash.Sized.Vector.Extra ( 4 | dropLe, 5 | takeLe, 6 | ) where 7 | 8 | import Clash.Prelude 9 | 10 | -- | Like 'drop' but uses a 'Data.Type.Ord.<=' constraint 11 | dropLe :: 12 | forall 13 | (n :: Nat) 14 | (m :: Nat) 15 | (a :: Type). 16 | (n <= m) => 17 | -- | How many elements to take 18 | SNat n -> 19 | -- | input vector 20 | Vec m a -> 21 | Vec (m - n) a 22 | dropLe SNat vs = leToPlus @n @m $ dropI vs 23 | 24 | -- | Like 'take' but uses a 'Data.Type.Ord.<=' constraint 25 | takeLe :: 26 | forall 27 | (n :: Nat) 28 | (m :: Nat) 29 | (a :: Type). 30 | (n <= m) => 31 | -- | How many elements to take 32 | SNat n -> 33 | -- | input vector 34 | Vec m a -> 35 | Vec n a 36 | takeLe SNat vs = leToPlus @n @m $ takeI vs 37 | -------------------------------------------------------------------------------- /clash-protocols/src/Data/Constraint/Nat/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | {- 4 | NOTE [constraint solver addition] 5 | 6 | The functions in this module enable us introduce trivial constraints that are not 7 | solved by the constraint solver. 8 | -} 9 | module Data.Constraint.Nat.Extra where 10 | 11 | import Clash.Prelude 12 | import Data.Constraint 13 | import Unsafe.Coerce (unsafeCoerce) 14 | 15 | {- | Postulates that multiplying some number /a/ by some constant /b/, and 16 | subsequently dividing that result by /b/ equals /a/. 17 | -} 18 | cancelMulDiv :: forall a b. (1 <= b) => Dict (DivRU (a * b) b ~ a) 19 | cancelMulDiv = unsafeCoerce (Dict :: Dict (0 ~ 0)) 20 | 21 | -- | if (1 <= b) then (Mod a b + 1 <= b) 22 | leModulusDivisor :: forall a b. (1 <= b) => Dict (Mod a b + 1 <= b) 23 | leModulusDivisor = unsafeCoerce (Dict :: Dict (0 <= 0)) 24 | 25 | -- | if (1 <= a) and (1 <= b) then (1 <= DivRU a b) 26 | strictlyPositiveDivRu :: forall a b. (1 <= a, 1 <= b) => Dict (1 <= DivRU a b) 27 | strictlyPositiveDivRu = unsafeCoerce (Dict :: Dict (0 <= 0)) 28 | 29 | -- | if (1 <= a) then (b <= ceil(b/a) * a) 30 | leTimesDivRu :: forall a b. (1 <= a) => Dict (b <= a * DivRU b a) 31 | leTimesDivRu = unsafeCoerce (Dict :: Dict (0 <= 0)) 32 | 33 | -- | if (1 <= a) then (a * ceil(b/a) ~ b + Mod (a - Mod b a) a) 34 | eqTimesDivRu :: forall a b. (1 <= a) => Dict (a * DivRU b a ~ b + Mod (a - Mod b a) a) 35 | eqTimesDivRu = unsafeCoerce (Dict :: Dict (0 ~ 0)) 36 | -------------------------------------------------------------------------------- /clash-protocols/src/Data/Maybe/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.Maybe.Extra ( 2 | toMaybe, 3 | ) where 4 | 5 | -- | Wrap a value in a @Just@ if @True@ 6 | toMaybe :: Bool -> a -> Maybe a 7 | toMaybe True x = Just x 8 | toMaybe False _ = Nothing 9 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | See 'Circuit' for documentation. This module is designed to import unqualified, 3 | i.e. using: 4 | 5 | @ 6 | import Protocols 7 | @ 8 | 9 | Definitions of 'Circuit', 'Fwd', 'Bwd', 'Protocols.Df.Df', inspired by 10 | definitions in @circuit-notation@ at . 11 | -} 12 | module Protocols ( 13 | -- * Circuit definition 14 | Circuit (Circuit), 15 | Protocol (Fwd, Bwd), 16 | Backpressure (boolsToBwd), 17 | Ack (..), 18 | Reverse, 19 | 20 | -- * Combinators & functions 21 | (|>), 22 | (<|), 23 | fromSignals, 24 | toSignals, 25 | 26 | -- * Protocol types 27 | CSignal, 28 | Df, 29 | 30 | -- * Basic circuits 31 | idC, 32 | repeatC, 33 | prod2C, 34 | 35 | -- * Simulation 36 | Simulate ( 37 | SimulateFwdType, 38 | SimulateBwdType, 39 | SimulateChannels, 40 | sigToSimFwd, 41 | sigToSimBwd, 42 | simToSigFwd, 43 | simToSigBwd, 44 | stallC 45 | ), 46 | Drivable ( 47 | ExpectType, 48 | toSimulateType, 49 | fromSimulateType, 50 | driveC, 51 | sampleC 52 | ), 53 | SimulationConfig (..), 54 | StallAck (..), 55 | simulateC, 56 | simulateCS, 57 | def, 58 | 59 | -- * Circuit notation plugin 60 | circuit, 61 | (-<), 62 | Units (..), 63 | TaggedBundle (..), 64 | ) where 65 | 66 | import Data.Default (def) 67 | import Protocols.Df (Df) 68 | import Protocols.Internal 69 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Avalon/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- Hashable (Unsigned n) 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | {- | 8 | Types and instance declarations for the Avalon-stream protocol. 9 | -} 10 | module Protocols.Avalon.Stream where 11 | 12 | -- base 13 | import Control.DeepSeq (NFData) 14 | import Control.Monad (when) 15 | import Control.Monad.State (get, gets, modify, put) 16 | import Data.Hashable (Hashable) 17 | import Data.Maybe qualified as Maybe 18 | import Data.Proxy 19 | import Prelude qualified as P 20 | 21 | -- clash-prelude 22 | import Clash.Prelude hiding (concat, length, take) 23 | import Clash.Prelude qualified as C 24 | 25 | -- me 26 | 27 | import Protocols.Df qualified as Df 28 | import Protocols.DfConv qualified as DfConv 29 | import Protocols.Hedgehog 30 | import Protocols.Idle 31 | import Protocols.Internal 32 | 33 | instance Hashable (C.Unsigned n) 34 | 35 | {- | Configuration for AXI4 Stream protocol. Determines the width of some 36 | fields in 'AvalonStreamM2S', and toggles some others. Also sets the ready 37 | latency (see specs for more info on this). 38 | -} 39 | data AvalonStreamConfig = AvalonStreamConfig 40 | { _channelWidth :: Nat 41 | , _errorWidth :: Nat 42 | , _keepStartOfPacket :: Bool 43 | , _keepEndOfPacket :: Bool 44 | , _emptyWidth :: Nat 45 | , _readyLatency :: Nat 46 | } 47 | 48 | -- | Grab '_channelWidth' at the type level. 49 | type family ChannelWidth (conf :: AvalonStreamConfig) where 50 | ChannelWidth ('AvalonStreamConfig a _ _ _ _ _) = a 51 | 52 | -- | Grab '_errorWidth' at the type level. 53 | type family ErrorWidth (conf :: AvalonStreamConfig) where 54 | ErrorWidth ('AvalonStreamConfig _ a _ _ _ _) = a 55 | 56 | -- | Grab '_keepStartOfPacket' at the type level. 57 | type family KeepStartOfPacket (conf :: AvalonStreamConfig) where 58 | KeepStartOfPacket ('AvalonStreamConfig _ _ a _ _ _) = a 59 | 60 | -- | Grab '_keepEndOfPacket' at the type level. 61 | type family KeepEndOfPacket (conf :: AvalonStreamConfig) where 62 | KeepEndOfPacket ('AvalonStreamConfig _ _ _ a _ _) = a 63 | 64 | -- | Grab '_emptyWidth' at the type level. 65 | type family EmptyWidth (conf :: AvalonStreamConfig) where 66 | EmptyWidth ('AvalonStreamConfig _ _ _ _ a _) = a 67 | 68 | -- | Grab '_readyLatency' at the type level. 69 | type family ReadyLatency (conf :: AvalonStreamConfig) where 70 | ReadyLatency ('AvalonStreamConfig _ _ _ _ _ a) = a 71 | 72 | {- | Shorthand for a "well-behaved" config, so that we don't need to write out 73 | a bunch of type constraints later. Holds for every configuration; don't worry 74 | about implementing this class. 75 | -} 76 | type KnownAvalonStreamConfig conf = 77 | ( KnownNat (ChannelWidth conf) 78 | , KnownNat (ErrorWidth conf) 79 | , KeepTypeClass (KeepStartOfPacket conf) 80 | , KeepTypeClass (KeepEndOfPacket conf) 81 | , KnownNat (EmptyWidth conf) 82 | , KnownNat (ReadyLatency conf) 83 | ) 84 | 85 | {- | Data sent from manager to subordinate. 86 | The tvalid field is left out: messages with 87 | @tvalid = False@ should be sent as a @Nothing@. 88 | -} 89 | data AvalonStreamM2S (conf :: AvalonStreamConfig) (dataType :: Type) = AvalonStreamM2S 90 | { _data :: dataType 91 | , _channel :: Unsigned (ChannelWidth conf) 92 | , _error :: Unsigned (ErrorWidth conf) 93 | , _startofpacket :: KeepType (KeepStartOfPacket conf) Bool 94 | , _endofpacket :: KeepType (KeepEndOfPacket conf) Bool 95 | , _empty :: Unsigned (EmptyWidth conf) 96 | } 97 | deriving (Generic, Bundle) 98 | 99 | deriving instance 100 | ( KnownAvalonStreamConfig conf 101 | , C.NFDataX dataType 102 | ) => 103 | C.NFDataX (AvalonStreamM2S conf dataType) 104 | 105 | deriving instance 106 | ( KnownAvalonStreamConfig conf 107 | , NFData dataType 108 | ) => 109 | NFData (AvalonStreamM2S conf dataType) 110 | 111 | deriving instance 112 | ( KnownAvalonStreamConfig conf 113 | , C.ShowX dataType 114 | ) => 115 | C.ShowX (AvalonStreamM2S conf dataType) 116 | 117 | deriving instance 118 | ( KnownAvalonStreamConfig conf 119 | , Show dataType 120 | ) => 121 | Show (AvalonStreamM2S conf dataType) 122 | 123 | deriving instance 124 | ( KnownAvalonStreamConfig conf 125 | , Eq dataType 126 | ) => 127 | Eq (AvalonStreamM2S conf dataType) 128 | 129 | deriving instance 130 | ( KnownAvalonStreamConfig conf 131 | , Hashable dataType 132 | ) => 133 | Hashable (AvalonStreamM2S conf dataType) 134 | 135 | {- | Data sent from subordinate to manager. A simple acknowledge message. 136 | Manager can only send 'AvalonStreamM2S' when '_ready' was true 137 | @readyLatency@ clock cycles ago. 138 | -} 139 | newtype AvalonStreamS2M (readyLatency :: Nat) = AvalonStreamS2M {_ready :: Bool} 140 | deriving stock (Generic, Show, Eq) 141 | deriving anyclass (C.NFDataX, C.ShowX, NFData, Bundle) 142 | 143 | -- | Type for Avalon Stream protocol. 144 | data AvalonStream (dom :: Domain) (conf :: AvalonStreamConfig) (dataType :: Type) 145 | 146 | instance Protocol (AvalonStream dom conf dataType) where 147 | type 148 | Fwd (AvalonStream dom conf dataType) = 149 | Signal dom (Maybe (AvalonStreamM2S conf dataType)) 150 | type 151 | Bwd (AvalonStream dom conf dataType) = 152 | Signal dom (AvalonStreamS2M (ReadyLatency conf)) 153 | 154 | instance 155 | (ReadyLatency conf ~ 0) => 156 | Backpressure (AvalonStream dom conf dataType) 157 | where 158 | boolsToBwd _ = C.fromList_lazy . fmap AvalonStreamS2M 159 | 160 | instance 161 | (KnownAvalonStreamConfig conf, NFDataX dataType) => 162 | DfConv.DfConv (AvalonStream dom conf dataType) 163 | where 164 | type Dom (AvalonStream dom conf dataType) = dom 165 | type 166 | FwdPayload (AvalonStream dom conf dataType) = 167 | AvalonStreamM2S conf dataType 168 | 169 | toDfCircuit proxy = DfConv.toDfCircuitHelper proxy s0 blankOtp stateFn 170 | where 171 | s0 = C.repeat @(ReadyLatency conf + 1) False 172 | blankOtp = Nothing 173 | stateFn (AvalonStreamS2M thisAck) _ otpItem = do 174 | modify (thisAck +>>) 175 | ackQueue <- get 176 | pure 177 | ( if Maybe.isJust otpItem && C.last ackQueue then otpItem else Nothing 178 | , Nothing 179 | , C.last ackQueue 180 | ) 181 | 182 | fromDfCircuit proxy = DfConv.fromDfCircuitHelper proxy s0 blankOtp stateFn 183 | where 184 | s0 = Nothing 185 | blankOtp = AvalonStreamS2M{_ready = False} 186 | stateFn m2s ack _ = do 187 | noCurrentVal <- gets Maybe.isNothing 188 | let msgOtp = AvalonStreamS2M{_ready = noCurrentVal} 189 | when noCurrentVal $ put m2s 190 | dfOtp <- get 191 | when (Maybe.isJust dfOtp && ack) $ put Nothing 192 | pure (msgOtp, dfOtp, False) 193 | 194 | instance 195 | ( ReadyLatency conf ~ 0 196 | , KnownAvalonStreamConfig conf 197 | , NFDataX dataType 198 | , KnownDomain dom 199 | ) => 200 | Simulate (AvalonStream dom conf dataType) 201 | where 202 | type 203 | SimulateFwdType (AvalonStream dom conf dataType) = 204 | [Maybe (AvalonStreamM2S conf dataType)] 205 | type SimulateBwdType (AvalonStream dom conf dataType) = [AvalonStreamS2M 0] 206 | type SimulateChannels (AvalonStream dom conf dataType) = 1 207 | 208 | simToSigFwd _ = fromList_lazy 209 | simToSigBwd _ = fromList_lazy 210 | sigToSimFwd _ s = sample_lazy s 211 | sigToSimBwd _ s = sample_lazy s 212 | 213 | stallC conf (head -> (stallAck, stalls)) = 214 | withClockResetEnable clockGen resetGen enableGen 215 | $ DfConv.stall Proxy Proxy conf stallAck stalls 216 | 217 | instance 218 | ( ReadyLatency conf ~ 0 219 | , KnownAvalonStreamConfig conf 220 | , NFDataX dataType 221 | , KnownDomain dom 222 | ) => 223 | Drivable (AvalonStream dom conf dataType) 224 | where 225 | type 226 | ExpectType (AvalonStream dom conf dataType) = 227 | [AvalonStreamM2S conf dataType] 228 | 229 | toSimulateType Proxy = P.map Just 230 | fromSimulateType Proxy = Maybe.catMaybes 231 | 232 | driveC conf vals = 233 | withClockResetEnable clockGen resetGen enableGen 234 | $ DfConv.drive Proxy conf vals 235 | sampleC conf ckt = 236 | withClockResetEnable clockGen resetGen enableGen 237 | $ DfConv.sample Proxy conf ckt 238 | 239 | instance 240 | ( ReadyLatency conf ~ 0 241 | , KnownAvalonStreamConfig conf 242 | , NFDataX dataType 243 | , NFData dataType 244 | , ShowX dataType 245 | , Show dataType 246 | , Eq dataType 247 | , KnownDomain dom 248 | ) => 249 | Test (AvalonStream dom conf dataType) 250 | where 251 | expectN Proxy = expectN (Proxy @(Df.Df dom _)) 252 | 253 | instance IdleCircuit (AvalonStream dom conf dataType) where 254 | idleFwd _ = pure Nothing 255 | idleBwd _ = pure AvalonStreamS2M{_ready = False} 256 | 257 | {- | Force a /nack/ on the backward channel and /no data/ on the forward 258 | channel if reset is asserted. 259 | -} 260 | forceResetSanity :: 261 | forall dom conf dataType. 262 | (C.HiddenClockResetEnable dom) => 263 | Circuit (AvalonStream dom conf dataType) (AvalonStream dom conf dataType) 264 | forceResetSanity = forceResetSanityGeneric 265 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Axi4/ReadData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | {- | 5 | Defines ReadData channel of full AXI4 protocol with port names corresponding 6 | to the AXI4 specification. 7 | -} 8 | module Protocols.Axi4.ReadData ( 9 | M2S_ReadData (..), 10 | S2M_ReadData (..), 11 | Axi4ReadData, 12 | 13 | -- * configuration 14 | Axi4ReadDataConfig (..), 15 | KnownAxi4ReadDataConfig, 16 | RKeepResponse, 17 | RIdWidth, 18 | 19 | -- * helpers 20 | forceResetSanity, 21 | ) where 22 | 23 | -- base 24 | import Data.Coerce (coerce) 25 | import Data.Kind (Type) 26 | import GHC.Generics (Generic) 27 | import Prelude hiding ( 28 | const, 29 | either, 30 | filter, 31 | fst, 32 | map, 33 | pure, 34 | snd, 35 | zip, 36 | zipWith, 37 | (!!), 38 | ) 39 | 40 | -- clash-prelude 41 | import Clash.Prelude qualified as C 42 | 43 | -- me 44 | import Protocols.Axi4.Common 45 | import Protocols.Idle 46 | import Protocols.Internal 47 | 48 | -- | Configuration options for 'Axi4ReadData'. 49 | data Axi4ReadDataConfig = Axi4ReadDataConfig 50 | { _rKeepResponse :: Bool 51 | , _rIdWidth :: C.Nat 52 | } 53 | 54 | {- | Grab '_rKeepResponse' from 'Axi4ReadDataConfig' at the type level. 55 | This boolean value determines whether to keep the '_rresp' field 56 | in 'S2M_ReadData'. 57 | -} 58 | type family RKeepResponse (conf :: Axi4ReadDataConfig) where 59 | RKeepResponse ('Axi4ReadDataConfig a _) = a 60 | 61 | {- | Grab '_rIdWidth' from 'Axi4ReadDataConfig' at the type level. 62 | This nat value determines the size of the '_rid' field 63 | in 'S2M_ReadData'. 64 | -} 65 | type family RIdWidth (conf :: Axi4ReadDataConfig) where 66 | RIdWidth ('Axi4ReadDataConfig _ a) = a 67 | 68 | -- | AXI4 Read Data channel protocol 69 | data 70 | Axi4ReadData 71 | (dom :: C.Domain) 72 | (conf :: Axi4ReadDataConfig) 73 | (userType :: Type) 74 | (dataType :: Type) 75 | 76 | instance Protocol (Axi4ReadData dom conf userType dataType) where 77 | type 78 | Fwd (Axi4ReadData dom conf userType dataType) = 79 | C.Signal dom (S2M_ReadData conf userType dataType) 80 | type 81 | Bwd (Axi4ReadData dom conf userType dataType) = 82 | C.Signal dom M2S_ReadData 83 | 84 | instance Backpressure (Axi4ReadData dom conf userType dataType) where 85 | boolsToBwd _ = C.fromList_lazy . coerce 86 | 87 | -- | See Table A2-6 "Read data channel signals" 88 | data 89 | S2M_ReadData 90 | (conf :: Axi4ReadDataConfig) 91 | (userType :: Type) 92 | (dataType :: Type) 93 | = S2M_NoReadData 94 | | S2M_ReadData 95 | { _rid :: C.BitVector (RIdWidth conf) 96 | -- ^ Read address id* 97 | , _rdata :: dataType 98 | -- ^ Read data 99 | , _rresp :: ResponseType (RKeepResponse conf) 100 | -- ^ Read response 101 | , _rlast :: Bool 102 | -- ^ Read last 103 | , _ruser :: userType 104 | -- ^ User data 105 | } 106 | deriving (Generic) 107 | 108 | -- | See Table A2-6 "Read data channel signals" 109 | newtype M2S_ReadData = M2S_ReadData {_rready :: Bool} 110 | deriving stock (Show, Generic) 111 | deriving anyclass (C.NFDataX, C.BitPack) 112 | 113 | {- | Shorthand for a "well-behaved" read data config, 114 | so that we don't need to write out a bunch of type constraints later. 115 | Holds for every configuration; don't worry about implementing this class. 116 | -} 117 | type KnownAxi4ReadDataConfig conf = 118 | ( KeepTypeClass (RKeepResponse conf) 119 | , C.KnownNat (RIdWidth conf) 120 | , Show (ResponseType (RKeepResponse conf)) 121 | , C.NFDataX (ResponseType (RKeepResponse conf)) 122 | , C.BitPack (ResponseType (RKeepResponse conf)) 123 | ) 124 | 125 | deriving instance 126 | ( KnownAxi4ReadDataConfig conf 127 | , Show userType 128 | , Show dataType 129 | ) => 130 | Show (S2M_ReadData conf userType dataType) 131 | 132 | deriving instance 133 | ( KnownAxi4ReadDataConfig conf 134 | , C.NFDataX userType 135 | , C.NFDataX dataType 136 | ) => 137 | C.NFDataX (S2M_ReadData conf userType dataType) 138 | 139 | instance IdleCircuit (Axi4ReadData dom conf userType dataType) where 140 | idleFwd _ = C.pure S2M_NoReadData 141 | idleBwd _ = C.pure $ M2S_ReadData False 142 | 143 | {- | Force a /nack/ on the backward channel and /no data/ on the forward 144 | channel if reset is asserted. 145 | -} 146 | forceResetSanity :: 147 | forall dom conf userType dataType. 148 | (C.HiddenClockResetEnable dom) => 149 | Circuit 150 | (Axi4ReadData dom conf userType dataType) 151 | (Axi4ReadData dom conf userType dataType) 152 | forceResetSanity = forceResetSanityGeneric 153 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Axi4/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- Hashable (Unsigned n) 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | {- | 7 | Types and instance declarations for the AXI4-stream protocol. 8 | -} 9 | module Protocols.Axi4.Stream where 10 | 11 | -- base 12 | import Control.DeepSeq (NFData) 13 | import Data.Hashable (Hashable, hashWithSalt) 14 | import Data.Maybe qualified as Maybe 15 | import Data.Proxy 16 | 17 | -- clash-prelude 18 | import Clash.Prelude hiding (concat, length, take) 19 | import Clash.Prelude qualified as C 20 | 21 | -- me 22 | 23 | import Protocols.Df qualified as Df 24 | import Protocols.DfConv qualified as DfConv 25 | import Protocols.Hedgehog 26 | import Protocols.Idle 27 | import Protocols.Internal 28 | 29 | instance (KnownNat n) => Hashable (Unsigned n) 30 | instance (KnownNat n, Hashable a) => Hashable (Vec n a) where 31 | hashWithSalt s v = hashWithSalt s (toList v) 32 | 33 | {- | Configuration for AXI4 Stream protocol. Determines the width of some 34 | fields in 'Axi4StreamM2S'. 35 | -} 36 | data Axi4StreamConfig = Axi4StreamConfig 37 | { _dataWidth :: Nat 38 | , _idWidth :: Nat 39 | , _destWidth :: Nat 40 | } 41 | 42 | -- | Grab '_dataWidth' at the type level. 43 | type family DataWidth (conf :: Axi4StreamConfig) where 44 | DataWidth ('Axi4StreamConfig a _ _) = a 45 | 46 | -- | Grab '_idWidth' at the type level. 47 | type family IdWidth (conf :: Axi4StreamConfig) where 48 | IdWidth ('Axi4StreamConfig _ a _) = a 49 | 50 | -- | Grab '_destWidth' at the type level. 51 | type family DestWidth (conf :: Axi4StreamConfig) where 52 | DestWidth ('Axi4StreamConfig _ _ a) = a 53 | 54 | {- | Shorthand for a "well-behaved" config, so that we don't need to write out 55 | a bunch of type constraints later. Holds for every configuration; don't worry 56 | about implementing this class. 57 | -} 58 | type KnownAxi4StreamConfig conf = 59 | ( KnownNat (DataWidth conf) 60 | , KnownNat (IdWidth conf) 61 | , KnownNat (DestWidth conf) 62 | ) 63 | 64 | {- | Data sent from manager to subordinate. The tvalid field is left out: messages with @tvalid = False@ 65 | should be sent as a @Nothing@. 66 | -} 67 | data Axi4StreamM2S (conf :: Axi4StreamConfig) (userType :: Type) = Axi4StreamM2S 68 | { _tdata :: Vec (DataWidth conf) (Unsigned 8) 69 | , _tkeep :: Vec (DataWidth conf) Bool 70 | , _tstrb :: Vec (DataWidth conf) Bool 71 | , _tlast :: Bool 72 | , _tid :: Unsigned (IdWidth conf) 73 | , _tdest :: Unsigned (DestWidth conf) 74 | , _tuser :: userType 75 | } 76 | deriving (Generic, C.ShowX, Show, NFData, Bundle) 77 | 78 | deriving instance 79 | ( KnownAxi4StreamConfig conf 80 | , C.NFDataX userType 81 | ) => 82 | C.NFDataX (Axi4StreamM2S conf userType) 83 | 84 | deriving instance 85 | ( KnownAxi4StreamConfig conf 86 | , Eq userType 87 | ) => 88 | Eq (Axi4StreamM2S conf userType) 89 | 90 | deriving instance 91 | ( KnownAxi4StreamConfig conf 92 | , Hashable userType 93 | ) => 94 | Hashable (Axi4StreamM2S conf userType) 95 | 96 | {- | Data sent from subordinate to manager. A simple acknowledge message. 97 | '_tready' may be on even when manager is sending 'Nothing'. 98 | Manager may not decide whether or not to send 'Nothing' based on 99 | the '_tready' signal. 100 | -} 101 | newtype Axi4StreamS2M = Axi4StreamS2M {_tready :: Bool} 102 | deriving stock (Show, Eq, Generic) 103 | deriving anyclass (C.NFDataX, C.ShowX, NFData, Bundle) 104 | 105 | -- | Type for AXI4 Stream protocol. 106 | data Axi4Stream (dom :: Domain) (conf :: Axi4StreamConfig) (userType :: Type) 107 | 108 | instance Protocol (Axi4Stream dom conf userType) where 109 | type Fwd (Axi4Stream dom conf userType) = Signal dom (Maybe (Axi4StreamM2S conf userType)) 110 | type Bwd (Axi4Stream dom conf userType) = Signal dom Axi4StreamS2M 111 | 112 | instance Backpressure (Axi4Stream dom conf userType) where 113 | boolsToBwd _ = C.fromList_lazy . fmap Axi4StreamS2M 114 | 115 | instance 116 | (KnownAxi4StreamConfig conf, NFDataX userType) => 117 | DfConv.DfConv (Axi4Stream dom conf userType) 118 | where 119 | type Dom (Axi4Stream dom conf userType) = dom 120 | type 121 | FwdPayload (Axi4Stream dom conf userType) = 122 | Axi4StreamM2S conf userType 123 | 124 | toDfCircuit proxy = DfConv.toDfCircuitHelper proxy s0 blankOtp stateFn 125 | where 126 | s0 = () 127 | blankOtp = Nothing 128 | stateFn ack _ otpItem = 129 | pure (otpItem, Nothing, Maybe.isJust otpItem C.&& _tready ack) 130 | 131 | fromDfCircuit proxy = DfConv.fromDfCircuitHelper proxy s0 blankOtp stateFn 132 | where 133 | s0 = () 134 | blankOtp = Axi4StreamS2M{_tready = False} 135 | stateFn m2s ack _ = 136 | pure (Axi4StreamS2M{_tready = ack}, m2s, False) 137 | 138 | instance 139 | (KnownAxi4StreamConfig conf, NFDataX userType, KnownDomain dom) => 140 | Simulate (Axi4Stream dom conf userType) 141 | where 142 | type 143 | SimulateFwdType (Axi4Stream dom conf userType) = 144 | [Maybe (Axi4StreamM2S conf userType)] 145 | type SimulateBwdType (Axi4Stream dom conf userType) = [Axi4StreamS2M] 146 | type SimulateChannels (Axi4Stream dom conf userType) = 1 147 | 148 | simToSigFwd _ = fromList_lazy 149 | simToSigBwd _ = fromList_lazy 150 | sigToSimFwd _ s = sample_lazy s 151 | sigToSimBwd _ s = sample_lazy s 152 | 153 | stallC conf (C.head -> (stallAck, stalls)) = 154 | withClockResetEnable clockGen resetGen enableGen $ 155 | DfConv.stall Proxy Proxy conf stallAck stalls 156 | 157 | instance 158 | (KnownAxi4StreamConfig conf, NFDataX userType, KnownDomain dom) => 159 | Drivable (Axi4Stream dom conf userType) 160 | where 161 | type 162 | ExpectType (Axi4Stream dom conf userType) = 163 | [Axi4StreamM2S conf userType] 164 | 165 | toSimulateType Proxy = fmap Just 166 | fromSimulateType Proxy = Maybe.catMaybes 167 | 168 | driveC conf vals = 169 | withClockResetEnable clockGen resetGen enableGen $ 170 | DfConv.drive Proxy conf vals 171 | sampleC conf ckt = 172 | withClockResetEnable clockGen resetGen enableGen $ 173 | DfConv.sample Proxy conf ckt 174 | 175 | instance 176 | ( KnownAxi4StreamConfig conf 177 | , NFDataX userType 178 | , NFData userType 179 | , ShowX userType 180 | , Show userType 181 | , Eq userType 182 | , KnownDomain dom 183 | ) => 184 | Test (Axi4Stream dom conf userType) 185 | where 186 | expectN Proxy = expectN (Proxy @(Df.Df dom _)) 187 | 188 | instance IdleCircuit (Axi4Stream dom conf userType) where 189 | idleFwd Proxy = C.pure Nothing 190 | idleBwd Proxy = C.pure $ Axi4StreamS2M False 191 | 192 | {- | Force a /nack/ on the backward channel and /no data/ on the forward 193 | channel if reset is asserted. 194 | -} 195 | forceResetSanity :: 196 | (KnownDomain dom, HiddenReset dom) => 197 | Circuit (Axi4Stream dom conf userType) (Axi4Stream dom conf userType) 198 | forceResetSanity = forceResetSanityGeneric 199 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Axi4/WriteData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | {- | 5 | Defines WriteData channel of full AXI4 protocol with port names corresponding 6 | to the AXI4 specification. 7 | -} 8 | module Protocols.Axi4.WriteData ( 9 | M2S_WriteData (..), 10 | S2M_WriteData (..), 11 | Axi4WriteData, 12 | 13 | -- * configuration 14 | Axi4WriteDataConfig (..), 15 | KnownAxi4WriteDataConfig, 16 | WKeepStrobe, 17 | WNBytes, 18 | ) where 19 | 20 | -- base 21 | import Data.Coerce (coerce) 22 | import Data.Kind (Type) 23 | import GHC.Generics (Generic) 24 | import Prelude hiding ( 25 | const, 26 | either, 27 | filter, 28 | fst, 29 | map, 30 | pure, 31 | snd, 32 | zip, 33 | zipWith, 34 | (!!), 35 | ) 36 | 37 | -- clash-prelude 38 | import Clash.Prelude qualified as C 39 | 40 | -- me 41 | import Protocols.Axi4.Common 42 | import Protocols.Idle 43 | import Protocols.Internal 44 | 45 | -- | Configuration options for 'Axi4WriteData'. 46 | data Axi4WriteDataConfig = Axi4WriteDataConfig 47 | { _wKeepStrobe :: Bool 48 | , _wNBytes :: C.Nat 49 | } 50 | 51 | {- | Grab '_wKeepStrobe' from 'Axi4WriteDataConfig' at the type level. 52 | This boolean value determines whether to keep strobe values in the '_wdata' field 53 | in 'M2S_WriteData'. 54 | -} 55 | type family WKeepStrobe (conf :: Axi4WriteDataConfig) where 56 | WKeepStrobe ('Axi4WriteDataConfig a _) = a 57 | 58 | {- | Grab '_wNBytes' from 'Axi4WriteDataConfig' at the type level. 59 | This nat value determines the size of the '_wdata' field 60 | in 'M2S_WriteData'. 61 | -} 62 | type family WNBytes (conf :: Axi4WriteDataConfig) where 63 | WNBytes ('Axi4WriteDataConfig _ a) = a 64 | 65 | -- | AXI4 Write Data channel protocol 66 | data 67 | Axi4WriteData 68 | (dom :: C.Domain) 69 | (conf :: Axi4WriteDataConfig) 70 | (userType :: Type) 71 | 72 | instance Protocol (Axi4WriteData dom conf userType) where 73 | type 74 | Fwd (Axi4WriteData dom conf userType) = 75 | C.Signal dom (M2S_WriteData conf userType) 76 | type 77 | Bwd (Axi4WriteData dom conf userType) = 78 | C.Signal dom S2M_WriteData 79 | 80 | instance Backpressure (Axi4WriteData dom conf userType) where 81 | boolsToBwd _ = C.fromList_lazy . coerce 82 | 83 | {- | See Table A2-3 "Write data channel signals". If strobing is kept, the data 84 | will be a vector of 'Maybe' bytes. If strobing is not kept, data will be a 85 | 'C.BitVector'. 86 | -} 87 | data 88 | M2S_WriteData 89 | (conf :: Axi4WriteDataConfig) 90 | (userType :: Type) 91 | = M2S_NoWriteData 92 | | M2S_WriteData 93 | { _wdata :: StrictStrobeType (WNBytes conf) (WKeepStrobe conf) 94 | -- ^ Write data 95 | , _wlast :: Bool 96 | -- ^ Write last 97 | , _wuser :: userType 98 | -- ^ User data 99 | } 100 | deriving (Generic) 101 | 102 | -- | See Table A2-3 "Write data channel signals" 103 | newtype S2M_WriteData = S2M_WriteData {_wready :: Bool} 104 | deriving stock (Show, Generic) 105 | deriving anyclass (C.NFDataX, C.BitPack) 106 | 107 | {- | Shorthand for a "well-behaved" write data config, 108 | so that we don't need to write out a bunch of type constraints later. 109 | Holds for every configuration; don't worry about implementing this class. 110 | -} 111 | type KnownAxi4WriteDataConfig conf = 112 | ( KeepStrobeClass (WKeepStrobe conf) 113 | , C.KnownNat (WNBytes conf) 114 | , Show (StrobeDataType (WKeepStrobe conf)) 115 | , C.NFDataX (StrobeDataType (WKeepStrobe conf)) 116 | , C.BitPack (StrobeDataType (WKeepStrobe conf)) 117 | ) 118 | 119 | deriving instance 120 | ( KnownAxi4WriteDataConfig conf 121 | , Show userType 122 | ) => 123 | Show (M2S_WriteData conf userType) 124 | 125 | deriving instance 126 | ( KnownAxi4WriteDataConfig conf 127 | , C.NFDataX userType 128 | ) => 129 | C.NFDataX (M2S_WriteData conf userType) 130 | 131 | instance IdleCircuit (Axi4WriteData dom conf userType) where 132 | idleFwd _ = C.pure M2S_NoWriteData 133 | idleBwd _ = C.pure S2M_WriteData{_wready = False} 134 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Axi4/WriteResponse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | {- | 5 | Defines WriteResponse channel of full AXI4 protocol with port names corresponding 6 | to the AXI4 specification. 7 | -} 8 | module Protocols.Axi4.WriteResponse ( 9 | M2S_WriteResponse (..), 10 | S2M_WriteResponse (..), 11 | Axi4WriteResponse, 12 | 13 | -- * configuration 14 | Axi4WriteResponseConfig (..), 15 | KnownAxi4WriteResponseConfig, 16 | BKeepResponse, 17 | BIdWidth, 18 | ) where 19 | 20 | -- base 21 | import Data.Coerce (coerce) 22 | import Data.Kind (Type) 23 | import GHC.Generics (Generic) 24 | 25 | -- clash-prelude 26 | import Clash.Prelude qualified as C 27 | 28 | -- me 29 | import Protocols.Axi4.Common 30 | import Protocols.Idle 31 | import Protocols.Internal 32 | 33 | -- | Configuration options for 'Axi4WriteResponse'. 34 | data Axi4WriteResponseConfig = Axi4WriteResponseConfig 35 | { _bKeepResponse :: Bool 36 | , _bIdWidth :: C.Nat 37 | } 38 | 39 | {- | Grab '_bKeepResponse' from 'Axi4WriteResponseConfig' at the type level. 40 | This boolean value determines whether to keep the '_bresp' field 41 | in 'S2M_WriteResponse'. 42 | -} 43 | type family BKeepResponse (conf :: Axi4WriteResponseConfig) where 44 | BKeepResponse ('Axi4WriteResponseConfig a _) = a 45 | 46 | {- | Grab '_bIdWidth' from 'Axi4WriteResponseConfig' at the type level. 47 | This nat value determines the size of the '_bid' field 48 | in 'S2M_WriteResponse'. 49 | -} 50 | type family BIdWidth (conf :: Axi4WriteResponseConfig) where 51 | BIdWidth ('Axi4WriteResponseConfig _ a) = a 52 | 53 | -- | AXI4 Read Data channel protocol 54 | data 55 | Axi4WriteResponse 56 | (dom :: C.Domain) 57 | (conf :: Axi4WriteResponseConfig) 58 | (userType :: Type) 59 | 60 | instance Protocol (Axi4WriteResponse dom conf userType) where 61 | type 62 | Fwd (Axi4WriteResponse dom conf userType) = 63 | C.Signal dom (S2M_WriteResponse conf userType) 64 | type 65 | Bwd (Axi4WriteResponse dom conf userType) = 66 | C.Signal dom M2S_WriteResponse 67 | 68 | instance Backpressure (Axi4WriteResponse dom conf userType) where 69 | boolsToBwd _ = C.fromList_lazy . coerce 70 | 71 | -- | See Table A2-4 "Write response channel signals" 72 | data 73 | S2M_WriteResponse 74 | (conf :: Axi4WriteResponseConfig) 75 | (userType :: Type) 76 | = S2M_NoWriteResponse 77 | | S2M_WriteResponse 78 | { _bid :: C.BitVector (BIdWidth conf) 79 | -- ^ Response ID 80 | , _bresp :: ResponseType (BKeepResponse conf) 81 | -- ^ Write response 82 | , _buser :: userType 83 | -- ^ User data 84 | } 85 | deriving (Generic) 86 | 87 | -- | See Table A2-4 "Write response channel signals" 88 | newtype M2S_WriteResponse = M2S_WriteResponse {_bready :: Bool} 89 | deriving stock (Show, Generic) 90 | deriving anyclass (C.NFDataX, C.BitPack) 91 | 92 | {- | Shorthand for a "well-behaved" write response config, 93 | so that we don't need to write out a bunch of type constraints later. 94 | Holds for every configuration; don't worry about implementing this class. 95 | -} 96 | type KnownAxi4WriteResponseConfig conf = 97 | ( KeepTypeClass (BKeepResponse conf) 98 | , C.KnownNat (BIdWidth conf) 99 | , Show (ResponseType (BKeepResponse conf)) 100 | , C.NFDataX (ResponseType (BKeepResponse conf)) 101 | , C.BitPack (ResponseType (BKeepResponse conf)) 102 | ) 103 | 104 | deriving instance 105 | ( KnownAxi4WriteResponseConfig conf 106 | , Show userType 107 | ) => 108 | Show (S2M_WriteResponse conf userType) 109 | 110 | deriving instance 111 | ( KnownAxi4WriteResponseConfig conf 112 | , C.NFDataX userType 113 | ) => 114 | C.NFDataX (S2M_WriteResponse conf userType) 115 | 116 | instance IdleCircuit (Axi4WriteResponse dom conf userType) where 117 | idleFwd _ = pure S2M_NoWriteResponse 118 | idleBwd _ = pure $ M2S_WriteResponse False 119 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Hedgehog/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | {-# OPTIONS_HADDOCK hide #-} 5 | 6 | {- | 7 | Internals for "Protocols.Hedgehog". 8 | -} 9 | module Protocols.Hedgehog.Internal ( 10 | module Protocols.Hedgehog.Internal, 11 | module Protocols.Hedgehog.Types, 12 | ) where 13 | 14 | -- base 15 | import Data.Proxy (Proxy (Proxy)) 16 | import GHC.Stack (HasCallStack) 17 | import Prelude 18 | 19 | -- clash-protocols 20 | import Protocols 21 | import Protocols.Hedgehog.Types 22 | import Protocols.Internal.TH 23 | 24 | -- clash-prelude 25 | import Clash.Prelude (type (*), type (+), type (<=)) 26 | import Clash.Prelude qualified as C 27 | 28 | -- hedgehog 29 | import Hedgehog qualified as H 30 | import Hedgehog.Internal.Property qualified as H 31 | 32 | {- | Resets for 30 cycles, checks for superfluous data for 50 cycles after 33 | seeing last valid data cycle, and times out after seeing 1000 consecutive 34 | empty cycles. 35 | -} 36 | defExpectOptions :: ExpectOptions 37 | defExpectOptions = 38 | ExpectOptions 39 | { -- XXX: These numbers are arbitrary, and should be adjusted to fit the 40 | -- protocol being tested. Annoyingly, upping these values will 41 | -- increase the time it takes to run the tests. This is because 42 | -- the test will run for at least the number of cycles specified 43 | -- in 'eoStopAfterEmpty'. 44 | eoStopAfterEmpty = 256 45 | , eoSampleMax = 256 46 | , eoResetCycles = 30 47 | , eoDriveEarly = True 48 | , eoTimeoutMs = Nothing 49 | , eoTrace = False 50 | } 51 | 52 | instance (TestType a, C.KnownDomain dom) => Test (Df dom a) where 53 | expectN :: 54 | forall m. 55 | (HasCallStack, H.MonadTest m) => 56 | Proxy (Df dom a) -> 57 | ExpectOptions -> 58 | [Maybe a] -> 59 | m [a] 60 | expectN Proxy (ExpectOptions{eoSampleMax, eoStopAfterEmpty}) sampled = do 61 | go eoSampleMax eoStopAfterEmpty sampled 62 | where 63 | go :: (HasCallStack) => Int -> Int -> [Maybe a] -> m [a] 64 | go _timeout _n [] = 65 | -- This really should not happen, protocols should produce data indefinitely 66 | error "unexpected end of signal" 67 | go 0 _ _ = 68 | -- Sample limit reached 69 | H.failWith 70 | Nothing 71 | ( "Sample limit reached after sampling " 72 | <> show eoSampleMax 73 | <> " samples. " 74 | <> "Consider increasing 'eoSampleMax' in 'ExpectOptions'." 75 | ) 76 | go _ 0 _ = 77 | -- Saw enough valid samples, return to user 78 | pure [] 79 | go sampleTimeout _emptyTimeout (Just a : as) = 80 | -- Valid sample 81 | (a :) <$> go (sampleTimeout - 1) eoStopAfterEmpty as 82 | go sampleTimeout emptyTimeout (Nothing : as) = 83 | -- Empty sample 84 | go sampleTimeout (emptyTimeout - 1) as 85 | 86 | instance 87 | ( Test a 88 | , C.KnownNat n 89 | , 1 <= (n * SimulateChannels a) 90 | , 1 <= n 91 | ) => 92 | Test (C.Vec n a) 93 | where 94 | expectN :: 95 | forall m. 96 | (HasCallStack, H.MonadTest m) => 97 | Proxy (C.Vec n a) -> 98 | ExpectOptions -> 99 | C.Vec n (SimulateFwdType a) -> 100 | m (C.Vec n (ExpectType a)) 101 | -- TODO: This creates some pretty terrible error messages, as one 102 | -- TODO: simulate channel is checked at a time. 103 | expectN Proxy opts = mapM (expectN (Proxy @a) opts) 104 | 105 | instance 106 | ( Test a 107 | , Test b 108 | , 1 <= (SimulateChannels a + SimulateChannels b) 109 | ) => 110 | Test (a, b) 111 | where 112 | expectN :: 113 | forall m. 114 | (HasCallStack, H.MonadTest m) => 115 | Proxy (a, b) -> 116 | ExpectOptions -> 117 | (SimulateFwdType a, SimulateFwdType b) -> 118 | m (ExpectType a, ExpectType b) 119 | expectN Proxy opts (sampledA, sampledB) = do 120 | -- TODO: This creates some pretty terrible error messages, as one 121 | -- TODO: simulate channel is checked at a time. 122 | trimmedA <- expectN (Proxy @a) opts sampledA 123 | trimmedB <- expectN (Proxy @b) opts sampledB 124 | pure (trimmedA, trimmedB) 125 | 126 | -- XXX: We only generate up to 9 tuples instead of maxTupleSize because NFData 127 | -- instances are only available up to 9-tuples. 128 | -- see https://hackage.haskell.org/package/deepseq-1.5.1.0/docs/src/Control.DeepSeq.html#line-1125 129 | testTupleInstances 3 9 130 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Hedgehog/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | {-# OPTIONS_HADDOCK hide #-} 4 | 5 | -- These types should be re-exported from the Protocols.Hedgehog module 6 | module Protocols.Hedgehog.Types where 7 | 8 | -- deepseq 9 | import Control.DeepSeq 10 | 11 | import Clash.Prelude qualified as C 12 | import Data.Proxy 13 | import GHC.Stack (HasCallStack) 14 | import Protocols.Internal.Types 15 | 16 | -- hedgehog 17 | import Hedgehog qualified as H 18 | 19 | -- | Superclass class to reduce syntactical noise. 20 | class (NFData a, C.NFDataX a, C.ShowX a, C.Show a, Eq a) => TestType a 21 | 22 | instance (NFData a, C.NFDataX a, C.ShowX a, C.Show a, Eq a) => TestType a 23 | 24 | -- | Options for 'expectN' function. See individual fields for more information. 25 | data ExpectOptions = ExpectOptions 26 | { eoStopAfterEmpty :: Int 27 | -- ^ Stop sampling after seeing /n/ consecutive empty samples 28 | , eoSampleMax :: Int 29 | -- ^ Produce an error if the circuit produces more than /n/ valid samples. This 30 | -- is used to terminate (potentially) infinitely running circuits. 31 | -- 32 | -- This number is used to generate stall information, so setting it to 33 | -- unreasonable values will result in long runtimes. 34 | , eoResetCycles :: Int 35 | -- ^ Ignore first /n/ cycles 36 | , eoDriveEarly :: Bool 37 | -- ^ Start driving the circuit with its reset asserted. Circuits should 38 | -- never acknowledge data while this is happening. 39 | , eoTimeoutMs :: Maybe Int 40 | -- ^ Terminate the test after /n/ milliseconds. 41 | , eoTrace :: Bool 42 | -- ^ Trace data generation for debugging purposes 43 | } 44 | 45 | {- | Provides a way of comparing expected data with data produced by a 46 | protocol component. 47 | -} 48 | class 49 | ( Drivable a 50 | , TestType (SimulateFwdType a) 51 | , TestType (ExpectType a) 52 | , -- Foldable requirement on Vec :( 53 | 1 C.<= SimulateChannels a 54 | ) => 55 | Test a 56 | where 57 | -- | Trim each channel to the lengths given as the third argument. See 58 | -- result documentation for failure modes. 59 | expectN :: 60 | (HasCallStack, H.MonadTest m) => 61 | Proxy a -> 62 | -- | Options, see 'ExpectOptions' 63 | ExpectOptions -> 64 | -- | Raw sampled data 65 | SimulateFwdType a -> 66 | -- | Depending on "ExpectOptions", fails the test if: 67 | -- 68 | -- * Circuit produced less data than expected 69 | -- * Circuit produced more data than expected 70 | -- 71 | -- If it does not fail, /SimulateFwdType a/ will contain exactly the number 72 | -- of expected data packets. 73 | -- 74 | -- TODO: 75 | -- Should probably return a 'Vec (SimulateChannels) Failures' 76 | -- in order to produce pretty reports. 77 | m (ExpectType a) 78 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Idle.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC "-Wno-orphans" #-} 2 | 3 | {- | 4 | Functionalities to easily create idle circuits for protocols. 5 | -} 6 | module Protocols.Idle ( 7 | -- * Type classes 8 | IdleCircuit (..), 9 | 10 | -- * Utility functions 11 | idleSource, 12 | idleSink, 13 | forceResetSanityGeneric, 14 | ) where 15 | 16 | import Clash.Prelude 17 | import Prelude () 18 | 19 | import Data.Proxy 20 | import Protocols.Internal 21 | import Protocols.Internal.TH (idleCircuitTupleInstances) 22 | import Protocols.Plugin.Cpp (maxTupleSize) 23 | 24 | instance (IdleCircuit a, IdleCircuit b) => IdleCircuit (a, b) where 25 | idleFwd _ = (idleFwd $ Proxy @a, idleFwd $ Proxy @b) 26 | idleBwd _ = (idleBwd $ Proxy @a, idleBwd $ Proxy @b) 27 | 28 | instance (IdleCircuit a, KnownNat n) => IdleCircuit (Vec n a) where 29 | idleFwd _ = repeat $ idleFwd $ Proxy @a 30 | idleBwd _ = repeat $ idleBwd $ Proxy @a 31 | 32 | instance IdleCircuit () where 33 | idleFwd _ = () 34 | idleBwd _ = () 35 | 36 | -- Derive instances for tuples up to maxTupleSize 37 | idleCircuitTupleInstances 3 maxTupleSize 38 | 39 | -- | Idle state of a source, this circuit does not produce any data. 40 | idleSource :: forall p. (IdleCircuit p) => Circuit () p 41 | idleSource = Circuit $ const ((), idleFwd $ Proxy @p) 42 | 43 | -- | Idle state of a sink, this circuit does not consume any data. 44 | idleSink :: forall p. (IdleCircuit p) => Circuit p () 45 | idleSink = Circuit $ const (idleBwd $ Proxy @p, ()) 46 | 47 | {- | Force a /nack/ on the backward channel and /no data/ on the forward 48 | channel if reset is asserted. 49 | -} 50 | forceResetSanityGeneric :: 51 | forall dom a fwd bwd. 52 | ( KnownDomain dom 53 | , HiddenReset dom 54 | , IdleCircuit a 55 | , Fwd a ~ Signal dom fwd 56 | , Bwd a ~ Signal dom bwd 57 | ) => 58 | Circuit a a 59 | forceResetSanityGeneric = Circuit go 60 | where 61 | go (fwd, bwd) = 62 | unbundle 63 | $ mux 64 | rstAsserted 65 | (bundle (idleBwd $ Proxy @a, idleFwd $ Proxy @a)) 66 | (bundle (bwd, fwd)) 67 | 68 | #if MIN_VERSION_clash_prelude(1,8,0) 69 | rstAsserted = unsafeToActiveHigh hasReset 70 | #else 71 | rstAsserted = unsafeToHighPolarity hasReset 72 | #endif 73 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Internal/TH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | 3 | module Protocols.Internal.TH where 4 | 5 | import Clash.Prelude qualified as C 6 | import Control.Monad (zipWithM) 7 | import Control.Monad.Extra (concatMapM) 8 | import Data.Proxy 9 | import GHC.TypeNats 10 | import Language.Haskell.TH 11 | import Protocols.Hedgehog.Types 12 | import Protocols.Internal.Types 13 | import Protocols.Plugin 14 | 15 | {- | Template haskell function to generate IdleCircuit instances for the tuples 16 | n through m inclusive. To see a 2-tuple version of the pattern we generate, 17 | see @Protocols.IdleCircuit@. 18 | -} 19 | idleCircuitTupleInstances :: Int -> Int -> DecsQ 20 | idleCircuitTupleInstances n m = concatMapM idleCircuitTupleInstance [n .. m] 21 | 22 | {- | Template Haskell function to generate an IdleCircuit instance for an 23 | n-tuple. 24 | -} 25 | idleCircuitTupleInstance :: Int -> DecsQ 26 | idleCircuitTupleInstance n = 27 | [d| 28 | instance ($instCtx) => IdleCircuit $instTy where 29 | idleFwd _ = $fwdExpr 30 | idleBwd _ = $bwdExpr 31 | |] 32 | where 33 | circTys = map (\i -> varT $ mkName $ "c" <> show i) [1 .. n] 34 | instCtx = foldl appT (tupleT n) $ map (\ty -> [t|IdleCircuit $ty|]) circTys 35 | instTy = foldl appT (tupleT n) circTys 36 | fwdExpr = tupE $ map mkFwdExpr circTys 37 | mkFwdExpr ty = [e|idleFwd $ Proxy @($ty)|] 38 | bwdExpr = tupE $ map mkBwdExpr circTys 39 | mkBwdExpr ty = [e|idleBwd $ Proxy @($ty)|] 40 | 41 | simulateTupleInstances :: Int -> Int -> DecsQ 42 | simulateTupleInstances n m = concatMapM simulateTupleInstance [n .. m] 43 | 44 | simulateTupleInstance :: Int -> DecsQ 45 | simulateTupleInstance n = 46 | [d| 47 | instance ($instCtx) => Simulate $instTy where 48 | type SimulateFwdType $instTy = $fwdType 49 | type SimulateBwdType $instTy = $bwdType 50 | type SimulateChannels $instTy = $channelSum 51 | 52 | simToSigFwd _ $fwdPat0 = $(tupE $ zipWith (\ty expr -> [e|simToSigFwd (Proxy @($ty)) $expr|]) circTys fwdExpr) 53 | simToSigBwd _ $bwdPat0 = $(tupE $ zipWith (\ty expr -> [e|simToSigBwd (Proxy @($ty)) $expr|]) circTys bwdExpr) 54 | sigToSimFwd _ $fwdPat0 = $(tupE $ zipWith (\ty expr -> [e|sigToSimFwd (Proxy @($ty)) $expr|]) circTys fwdExpr) 55 | sigToSimBwd _ $bwdPat0 = $(tupE $ zipWith (\ty expr -> [e|sigToSimBwd (Proxy @($ty)) $expr|]) circTys bwdExpr) 56 | 57 | stallC $(varP $ mkName "conf") $(varP $ mkName "rem0") = $stallCExpr 58 | |] 59 | where 60 | -- Generate the types for the instance 61 | circTys = map (\i -> varT $ mkName $ "c" <> show i) [1 .. n] 62 | instTy = foldl appT (tupleT n) circTys 63 | instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Simulate $ty|]) circTys 64 | fwdType = foldl appT (tupleT n) $ map (\ty -> [t|SimulateFwdType $ty|]) circTys 65 | bwdType = foldl appT (tupleT n) $ map (\ty -> [t|SimulateBwdType $ty|]) circTys 66 | channelSum = foldl1 (\a b -> [t|$a + $b|]) $ map (\ty -> [t|SimulateChannels $ty|]) circTys 67 | 68 | -- Relevant expressions and patterns 69 | fwdPat0 = tupP $ map (\i -> varP $ mkName $ "fwd" <> show i) [1 .. n] 70 | bwdPat0 = tupP $ map (\i -> varP $ mkName $ "bwd" <> show i) [1 .. n] 71 | fwdExpr = map (\i -> varE $ mkName $ "fwd" <> show i) [1 .. n] 72 | bwdExpr = map (\i -> varE $ mkName $ "bwd" <> show i) [1 .. n] 73 | fwdExpr1 = map (\i -> varE $ mkName $ "fwdStalled" <> show i) [1 .. n] 74 | bwdExpr1 = map (\i -> varE $ mkName $ "bwdStalled" <> show i) [1 .. n] 75 | 76 | -- stallC Declaration: Split off the stall vectors from the large input vector 77 | mkStallVec i ty = 78 | [d| 79 | $[p| 80 | ( $(varP (mkName $ "stalls" <> show i)) 81 | , $(varP (mkName $ if i == n then "_" else "rem" <> show i)) 82 | ) 83 | |] = 84 | C.splitAtI @(SimulateChannels $ty) 85 | $(varE $ mkName $ "rem" <> show (i - 1)) 86 | |] 87 | 88 | -- stallC Declaration: Generate stalling circuits 89 | mkStallCircuit i ty = 90 | [d| 91 | $[p|Circuit $(varP $ mkName $ "stalled" <> show i)|] = 92 | stallC @($ty) conf $(varE $ mkName $ "stalls" <> show i) 93 | |] 94 | 95 | -- Generate the stallC expression 96 | stallCExpr = do 97 | stallVecs <- 98 | concat <$> zipWithM mkStallVec [1 .. n] circTys 99 | stallCircuits <- 100 | concat <$> zipWithM mkStallCircuit [1 .. n] circTys 101 | LetE (stallVecs <> stallCircuits) 102 | <$> [e|Circuit $ \($fwdPat0, $bwdPat0) -> $circuitResExpr|] 103 | 104 | circuitResExpr = do 105 | stallCResultDecs <- concatMapM mkStallCResultDec [1 .. n] 106 | LetE stallCResultDecs <$> [e|($(tupE fwdExpr1), $(tupE bwdExpr1))|] 107 | 108 | mkStallCResultDec i = 109 | [d| 110 | $[p| 111 | ( $(varP $ mkName $ "fwdStalled" <> show i) 112 | , $(varP $ mkName $ "bwdStalled" <> show i) 113 | ) 114 | |] = 115 | $(varE $ mkName $ "stalled" <> show i) 116 | ( $(varE $ mkName $ "fwd" <> show i) 117 | , $(varE $ mkName $ "bwd" <> show i) 118 | ) 119 | |] 120 | 121 | drivableTupleInstances :: Int -> Int -> DecsQ 122 | drivableTupleInstances n m = concatMapM drivableTupleInstance [n .. m] 123 | 124 | drivableTupleInstance :: Int -> DecsQ 125 | drivableTupleInstance n = 126 | [d| 127 | instance ($instCtx) => Drivable $instTy where 128 | type 129 | ExpectType $instTy = 130 | $(foldl appT (tupleT n) $ map (\ty -> [t|ExpectType $ty|]) circTys) 131 | toSimulateType Proxy $(tupP circPats) = $toSimulateExpr 132 | 133 | fromSimulateType Proxy $(tupP circPats) = $fromSimulateExpr 134 | 135 | driveC $(varP $ mkName "conf") $(tupP fwdPats) = $(letE driveCDecs driveCExpr) 136 | sampleC conf (Circuit f) = 137 | let 138 | $(varP $ mkName "bools") = replicate (resetCycles conf) False <> repeat True 139 | $(tupP fwdPats) = snd $ f ((), $(tupE $ map mkSampleCExpr circTys)) 140 | in 141 | $( tupE $ 142 | zipWith (\ty fwd -> [|sampleC @($ty) conf (Circuit $ const ((), $fwd))|]) circTys fwdExprs 143 | ) 144 | |] 145 | where 146 | circStrings = map (\i -> "c" <> show i) [1 .. n] 147 | circTys = map (varT . mkName) circStrings 148 | circPats = map (varP . mkName) circStrings 149 | circExprs = map (varE . mkName) circStrings 150 | instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Drivable $ty|]) circTys 151 | instTy = foldl appT (tupleT n) circTys 152 | fwdPats = map (varP . mkName . ("fwd" <>)) circStrings 153 | fwdExprs = map (varE . mkName . ("fwd" <>)) circStrings 154 | bwdExprs = map (varE . mkName . ("bwd" <>)) circStrings 155 | bwdPats = map (varP . mkName . ("bwd" <>)) circStrings 156 | 157 | mkSampleCExpr ty = [e|boolsToBwd (Proxy @($ty)) bools|] 158 | driveCDecs = 159 | pure $ 160 | valD 161 | (tupP $ map (\p -> [p|(Circuit $p)|]) circPats) 162 | (normalB $ tupE $ zipWith (\ty fwd -> [e|driveC @($ty) conf $fwd|]) circTys fwdExprs) 163 | [] 164 | 165 | driveCExpr = 166 | [e| 167 | Circuit $ \(_, $(tildeP $ tupP bwdPats)) -> ((), $(tupE $ zipWith mkDriveCExpr circExprs bwdExprs)) 168 | |] 169 | mkDriveCExpr c bwd = [e|snd ($c ((), $bwd))|] 170 | toSimulateExpr = tupE $ zipWith (\ty c -> [|toSimulateType (Proxy @($ty)) $c|]) circTys circExprs 171 | fromSimulateExpr = tupE $ zipWith (\ty c -> [|fromSimulateType (Proxy @($ty)) $c|]) circTys circExprs 172 | 173 | backPressureTupleInstances :: Int -> Int -> DecsQ 174 | backPressureTupleInstances n m = concatMapM backPressureTupleInstance [n .. m] 175 | 176 | backPressureTupleInstance :: Int -> DecsQ 177 | backPressureTupleInstance n = 178 | [d| 179 | instance ($instCtx) => Backpressure $instTy where 180 | boolsToBwd _ bs = $(tupE $ map (\ty -> [e|boolsToBwd (Proxy @($ty)) bs|]) circTys) 181 | |] 182 | where 183 | circTys = map (\i -> varT $ mkName $ "c" <> show i) [1 .. n] 184 | instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Backpressure $ty|]) circTys 185 | instTy = foldl appT (tupleT n) circTys 186 | 187 | testTupleInstances :: Int -> Int -> DecsQ 188 | testTupleInstances n m = concatMapM testTupleInstance [n .. m] 189 | 190 | testTupleInstance :: Int -> DecsQ 191 | testTupleInstance n = 192 | [d| 193 | instance ($instCtx) => Test $instTy where 194 | expectN Proxy $(varP $ mkName "opts") $(tupP sampledPats) = $(doE stmts) 195 | |] 196 | where 197 | circStrings = map (\i -> "c" <> show i) [1 .. n] 198 | circTys = map (varT . mkName) circStrings 199 | instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Test $ty|]) circTys 200 | instTy = foldl appT (tupleT n) circTys 201 | 202 | sampledPats = map (varP . mkName . ("sampled" <>)) circStrings 203 | sampledExprs = map (varE . mkName . ("sampled" <>)) circStrings 204 | trimmedPats = map (varP . mkName . ("trimmed" <>)) circStrings 205 | trimmedExprs = map (varE . mkName . ("trimmed" <>)) circStrings 206 | 207 | mkTrimStmt trim ty sam = bindS trim [e|expectN (Proxy @($ty)) opts $sam|] 208 | expectResult = noBindS [e|pure $(tupE trimmedExprs)|] 209 | stmts = zipWith3 mkTrimStmt trimmedPats circTys sampledExprs <> [expectResult] 210 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | module Protocols.Internal.Types where 2 | 3 | import Clash.Prelude qualified as C 4 | import Data.Default (Default (..)) 5 | import Data.Proxy 6 | import GHC.Base (Type) 7 | import Protocols.Plugin 8 | 9 | {- $setup 10 | >>> import Protocols 11 | -} 12 | 13 | {- | Idle state of a Circuit. Aims to provide no data for both the forward and 14 | backward direction. Transactions are not acknowledged. 15 | -} 16 | class (Protocol p) => IdleCircuit p where 17 | idleFwd :: Proxy p -> Fwd (p :: Type) 18 | idleBwd :: Proxy p -> Bwd (p :: Type) 19 | 20 | -- | Conversion from booleans to protocol specific acknowledgement values. 21 | class (Protocol a) => Backpressure a where 22 | -- | Interpret list of booleans as a list of acknowledgements at every cycle. 23 | -- Implementations don't have to account for finite lists. 24 | boolsToBwd :: Proxy a -> [Bool] -> Bwd a 25 | 26 | {- | Specifies option for simulation functions. Don't use this constructor 27 | directly, as it may be extend with other options in the future. Use 'def' 28 | instead. 29 | -} 30 | data SimulationConfig = SimulationConfig 31 | { resetCycles :: Int 32 | -- ^ Assert reset for a number of cycles before driving the protocol 33 | -- 34 | -- Default: 100 35 | , timeoutAfter :: Int 36 | -- ^ Timeout after /n/ cycles. Only affects sample functions. 37 | -- 38 | -- Default: 'maxBound' 39 | , ignoreReset :: Bool 40 | -- ^ Ignore cycles while in reset (sampleC) 41 | -- 42 | -- Default: False 43 | } 44 | deriving (Show) 45 | 46 | instance Default SimulationConfig where 47 | def = 48 | SimulationConfig 49 | { resetCycles = 100 50 | , timeoutAfter = maxBound 51 | , ignoreReset = False 52 | } 53 | 54 | {- | Determines what kind of acknowledgement signal 'stallC' will send when its 55 | input component is not sending any data. Note that, in the Df protocol, 56 | protocols may send arbitrary acknowledgement signals when this happens. 57 | -} 58 | data StallAck 59 | = -- | Send Nack 60 | StallWithNack 61 | | -- | Send Ack 62 | StallWithAck 63 | | -- | Send @errorX "No defined ack"@ 64 | StallWithErrorX 65 | | -- | Passthrough acknowledgement of RHS component 66 | StallTransparently 67 | | -- | Cycle through all modes 68 | StallCycle 69 | deriving (Eq, Bounded, Enum, Show) 70 | 71 | {- | Class that defines how to /drive/, /sample/, and /stall/ a "Circuit" of 72 | some shape. The "Backpressure" instance requires that the /backward/ type of the 73 | circuit can be generated from a list of Booleans. 74 | -} 75 | class (C.KnownNat (SimulateChannels a), Backpressure a, Simulate a) => Drivable a where 76 | -- TODO: documentatie verplaatsen 77 | -- Type a /Circuit/ driver needs or sampler yields. For example: 78 | -- 79 | -- >>> :kind! (forall dom a. SimulateFwdType (Df dom a)) 80 | -- ... 81 | -- = [Data a] 82 | -- 83 | -- This means sampling a @Circuit () (Df dom a)@ with 'sampleC' yields 84 | -- @[Data a]@. 85 | 86 | -- | Similar to 'SimulateFwdType', but without backpressure information. For 87 | -- example: 88 | -- 89 | -- >>> :kind! (forall dom a. ExpectType (Df dom a)) 90 | -- ... 91 | -- = [a] 92 | -- 93 | -- Useful in situations where you only care about the "pure functionality" of 94 | -- a circuit, not its timing information. Leveraged by various functions 95 | -- in "Protocols.Hedgehog" and 'Protocols.Internal.simulateCS'. 96 | type ExpectType a :: Type 97 | 98 | -- | Convert a /ExpectType a/, a type representing data without backpressure, 99 | -- into a type that does, /SimulateFwdType a/. 100 | toSimulateType :: 101 | -- | Type witness 102 | Proxy a -> 103 | -- | Expect type: input for a protocol /without/ stall information 104 | ExpectType a -> 105 | -- | Expect type: input for a protocol /with/ stall information 106 | SimulateFwdType a 107 | 108 | -- | Convert a /ExpectType a/, a type representing data without backpressure, 109 | -- into a type that does, /SimulateFwdType a/. 110 | fromSimulateType :: 111 | -- | Type witness 112 | Proxy a -> 113 | -- | Expect type: input for a protocol /with/ stall information 114 | SimulateFwdType a -> 115 | -- | Expect type: input for a protocol /without/ stall information 116 | ExpectType a 117 | 118 | -- | Create a /driving/ circuit. Can be used in combination with 'sampleC' 119 | -- to simulate a circuit. Related: 'Protocols.Internal.simulateC'. 120 | driveC :: 121 | SimulationConfig -> 122 | SimulateFwdType a -> 123 | Circuit () a 124 | 125 | -- | Sample a circuit that is trivially drivable. Use 'driveC' to create 126 | -- such a circuit. Related: 'Protocols.Internal.simulateC'. 127 | sampleC :: 128 | SimulationConfig -> 129 | Circuit () a -> 130 | SimulateFwdType a 131 | 132 | {- | Defines functions necessary for implementation of the 'Protocols.Internal.simulateCircuit' function. This 133 | kind of simulation requires a lists for both the forward and the backward direction. 134 | 135 | This class requires the definition of the types that the test supplies and returns. Its 136 | functions are converters from these /simulation types/ to types on the 'Clash.Signal.Signal' level. 137 | The 'Protocols.Internal.simulateCircuit' function can thus receive the necessary simulation types, convert 138 | them to types on the 'Clash.Signal.Signal' level, pass those signals to the circuit, and convert the 139 | result of the circuit back to the simulation types giving the final result. 140 | -} 141 | class (C.KnownNat (SimulateChannels a), Protocol a) => Simulate a where 142 | -- | The type that a test must provide to the 'Protocols.Internal.simulateCircuit' function in the forward direction. 143 | -- Usually this is some sort of list. 144 | type SimulateFwdType a :: Type 145 | 146 | -- | The type that a test must provide to the 'Protocols.Internal.simulateCircuit' function in the backward direction. 147 | -- Usually this is some sort of list 148 | type SimulateBwdType a :: Type 149 | 150 | -- | The number of simulation channels this channel has after flattening it. 151 | -- For example, @(Df dom a, Df dom a)@ has 2, while 152 | -- @Vec 4 (Df dom a, Df dom a)@ has 8. 153 | type SimulateChannels a :: C.Nat 154 | 155 | -- | Convert the forward simulation type to the 'Fwd' of @a@. 156 | simToSigFwd :: Proxy a -> SimulateFwdType a -> Fwd a 157 | 158 | -- | Convert the backward simulation type to the 'Bwd' of @a@. 159 | simToSigBwd :: Proxy a -> SimulateBwdType a -> Bwd a 160 | 161 | -- | Convert a signal of type @Bwd a@ to the backward simulation type. 162 | sigToSimFwd :: Proxy a -> Fwd a -> SimulateFwdType a 163 | 164 | -- | Convert a signal of type @Fwd a@ to the forward simulation type. 165 | sigToSimBwd :: Proxy a -> Bwd a -> SimulateBwdType a 166 | 167 | -- | Create a /stalling/ circuit. For each simulation channel (see 168 | -- 'SimulateChannels') a tuple determines how the component stalls: 169 | -- 170 | -- * 'StallAck': determines how the backward (acknowledgement) channel 171 | -- should behave whenever the component does not receive data from the 172 | -- left hand side or when it's intentionally stalling. 173 | -- 174 | -- * A list of 'Int's that determine how many stall cycles to insert on 175 | -- every cycle the left hand side component produces data. I.e., stalls 176 | -- are /not/ inserted whenever the left hand side does /not/ produce data. 177 | stallC :: 178 | SimulationConfig -> 179 | C.Vec (SimulateChannels a) (StallAck, [Int]) -> 180 | Circuit a a 181 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/PacketStream.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Copyright : (C) 2024, QBayLogic B.V. 3 | License : BSD2 (see the file LICENSE) 4 | Maintainer : QBayLogic B.V. 5 | 6 | Provides the PacketStream protocol, a simple streaming protocol for transferring packets of data between components. 7 | 8 | Apart from the protocol definition, some components, all of which are generic in @dataWidth@, are also provided: 9 | 10 | 1. Several small utilities such as filtering a stream based on its metadata. 11 | 2. Fifos 12 | 3. Components which upsize or downsize @dataWidth@ 13 | 4. Components which read from the stream (depacketizers) 14 | 5. Components which write to the stream (packetizers) 15 | 6. Components which split and merge a stream based on its metadata 16 | -} 17 | module Protocols.PacketStream ( 18 | module Protocols.PacketStream.Base, 19 | 20 | -- * Fifos 21 | module Protocols.PacketStream.PacketFifo, 22 | module Protocols.PacketStream.AsyncFifo, 23 | 24 | -- * Converters 25 | module Protocols.PacketStream.Converters, 26 | 27 | -- * Depacketizers 28 | module Protocols.PacketStream.Depacketizers, 29 | 30 | -- * Packetizers 31 | module Protocols.PacketStream.Packetizers, 32 | 33 | -- * Padding removal 34 | module Protocols.PacketStream.Padding, 35 | 36 | -- * Routing components 37 | module Protocols.PacketStream.Routing, 38 | ) 39 | where 40 | 41 | import Protocols.PacketStream.AsyncFifo 42 | import Protocols.PacketStream.Base 43 | import Protocols.PacketStream.Converters 44 | import Protocols.PacketStream.Depacketizers 45 | import Protocols.PacketStream.PacketFifo 46 | import Protocols.PacketStream.Packetizers 47 | import Protocols.PacketStream.Padding 48 | import Protocols.PacketStream.Routing 49 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/PacketStream/AsyncFifo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | {- | 5 | Copyright : (C) 2024, QBayLogic B.V. 6 | License : BSD2 (see the file LICENSE) 7 | Maintainer : QBayLogic B.V. 8 | 9 | Provides `asyncFifoC` for crossing clock domains in the packet stream protocol. 10 | -} 11 | module Protocols.PacketStream.AsyncFifo (asyncFifoC) where 12 | 13 | import Data.Maybe.Extra (toMaybe) 14 | 15 | import Clash.Explicit.Prelude (asyncFIFOSynchronizer) 16 | import Clash.Prelude 17 | 18 | import Protocols 19 | import Protocols.PacketStream.Base 20 | 21 | {- | Asynchronous FIFO circuit that can be used to safely cross clock domains. 22 | Uses `Clash.Explicit.Prelude.asyncFIFOSynchronizer` internally. 23 | -} 24 | asyncFifoC :: 25 | forall 26 | (wDom :: Domain) 27 | (rDom :: Domain) 28 | (depth :: Nat) 29 | (dataWidth :: Nat) 30 | (meta :: Type). 31 | (KnownDomain wDom) => 32 | (KnownDomain rDom) => 33 | (KnownNat depth) => 34 | (KnownNat dataWidth) => 35 | (2 <= depth) => 36 | (1 <= dataWidth) => 37 | (NFDataX meta) => 38 | -- | 2^depth is the number of elements this component can store 39 | SNat depth -> 40 | -- | Clock signal in the write domain 41 | Clock wDom -> 42 | -- | Reset signal in the write domain 43 | Reset wDom -> 44 | -- | Enable signal in the write domain 45 | Enable wDom -> 46 | -- | Clock signal in the read domain 47 | Clock rDom -> 48 | -- | Reset signal in the read domain 49 | Reset rDom -> 50 | -- | Enable signal in the read domain 51 | Enable rDom -> 52 | Circuit (PacketStream wDom dataWidth meta) (PacketStream rDom dataWidth meta) 53 | asyncFifoC depth wClk wRst wEn rClk rRst rEn = 54 | exposeClockResetEnable forceResetSanity wClk wRst wEn |> fromSignals ckt 55 | where 56 | ckt (fwdIn, bwdIn) = (bwdOut, fwdOut) 57 | where 58 | (element, isEmpty, isFull) = asyncFIFOSynchronizer depth wClk rClk wRst rRst wEn rEn readReq fwdIn 59 | notEmpty = not <$> isEmpty 60 | -- If the FIFO is empty, we output Nothing. Else, we output the oldest element. 61 | fwdOut = toMaybe <$> notEmpty <*> element 62 | -- Assert backpressure when the FIFO is full. 63 | bwdOut = PacketStreamS2M . not <$> isFull 64 | -- Next component is ready to read if the fifo is not empty and it does not assert backpressure. 65 | readReq = notEmpty .&&. _ready <$> bwdIn 66 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/PacketStream/Padding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | {- | 5 | Copyright : (C) 2024, QBayLogic B.V. 6 | License : BSD2 (see the file LICENSE) 7 | Maintainer : QBayLogic B.V. 8 | 9 | Provides a generic component which enforces some expected packet length field 10 | in the metadata. 11 | -} 12 | module Protocols.PacketStream.Padding ( 13 | stripPaddingC, 14 | ) where 15 | 16 | import Clash.Prelude 17 | 18 | import Data.Bifunctor qualified as B 19 | import Data.Maybe 20 | import Data.Type.Equality ((:~:) (Refl)) 21 | 22 | import Protocols 23 | import Protocols.PacketStream.Base 24 | 25 | -- | State of `stripPaddingT`. 26 | data StripPaddingState p dataWidth meta 27 | = Counting 28 | { _buffer :: PacketStreamM2S dataWidth meta 29 | -- ^ Contains the last transfer, with `_abort` set if a premature end 30 | -- was detected. If the packet contained padding, `_last` is already 31 | -- correctly adjusted. 32 | , _valid :: Bool 33 | -- ^ Qualifier for _buffer. If false, its value is undefined. 34 | , _counter :: Unsigned p 35 | -- ^ Counts the actual length of the current packet. 36 | } 37 | | Strip 38 | { _buffer :: PacketStreamM2S dataWidth meta 39 | -- ^ We need to wait until forwarding the last transfer, as the padding 40 | -- may be aborted. In this state we do not need _valid, as the buffered 41 | -- transfer is always valid. 42 | } 43 | deriving (Generic, NFDataX) 44 | 45 | -- | State transition function of `stripPaddingC`. 46 | stripPaddingT :: 47 | forall dataWidth meta p. 48 | (KnownNat dataWidth) => 49 | (KnownNat p) => 50 | (meta -> Unsigned p) -> 51 | StripPaddingState p dataWidth meta -> 52 | ( Maybe (PacketStreamM2S dataWidth meta) 53 | , PacketStreamS2M 54 | ) -> 55 | ( StripPaddingState p dataWidth meta 56 | , ( PacketStreamS2M 57 | , Maybe (PacketStreamM2S dataWidth meta) 58 | ) 59 | ) 60 | stripPaddingT _ st@Counting{} (Nothing, bwdIn) = (nextSt, (PacketStreamS2M True, fwdOut)) 61 | where 62 | fwdOut = 63 | if _valid st 64 | then Just (_buffer st) 65 | else Nothing 66 | 67 | nextSt 68 | | isJust fwdOut && _ready bwdIn = st{_valid = False} 69 | | otherwise = st 70 | stripPaddingT toLength st@Counting{} (Just inPkt, bwdIn) = (nextSt, (bwdOut, fwdOut)) 71 | where 72 | expectedLen = toLength (_meta inPkt) 73 | 74 | toAdd :: Unsigned p 75 | toAdd = case _last inPkt of 76 | Nothing -> natToNum @dataWidth 77 | -- Here we do a slightly dangerous resize. Because @dataWidth@ should 78 | -- never be bigger than @2^p@, this is not an issue in practice, so I 79 | -- don't believe it requires a constraint as long as it is well-documented. 80 | Just size -> bitCoerce (resize size :: Index (2 ^ p)) 81 | 82 | carry :: Bool 83 | nextCount :: Unsigned p 84 | (carry, nextCount) = 85 | B.bimap unpack unpack 86 | $ split 87 | $ add (_counter st) toAdd 88 | 89 | -- True if the payload size is smaller than expected. 90 | -- We have to take the carry into account as well, otherwise if the 91 | -- calculation overflows then we will wrongly signal a premature end. 92 | prematureEnd = 93 | isJust (_last inPkt) 94 | && (nextCount < expectedLen) 95 | && not carry 96 | 97 | tooBig = nextCount > expectedLen || carry 98 | 99 | fwdOut = 100 | if _valid st 101 | then Just (_buffer st) 102 | else Nothing 103 | 104 | bwdOut = PacketStreamS2M (isNothing fwdOut || _ready bwdIn) 105 | 106 | nextLast 107 | -- If @dataWidth is 1, the adjusted `_last` is always @Just 0@. 108 | -- Otherwise, we need to do some arithmetic. 109 | | tooBig = case sameNat d1 (SNat @dataWidth) of 110 | Just Refl -> Just 0 111 | Nothing -> Just $ bitCoerce $ resize $ expectedLen - _counter st 112 | | otherwise = _last inPkt 113 | 114 | nextBuf = inPkt{_last = nextLast, _abort = _abort inPkt || prematureEnd} 115 | nextValid = isJust (_last inPkt) || not tooBig 116 | 117 | nextCounter = 118 | if prematureEnd || isJust (_last inPkt) 119 | then 0 120 | else nextCount 121 | 122 | nextSt 123 | | isJust fwdOut && not (_ready bwdIn) = st 124 | | isNothing (_last inPkt) && tooBig = Strip nextBuf 125 | | otherwise = Counting nextBuf nextValid nextCounter 126 | stripPaddingT _ st@Strip{} (Nothing, _) = (st, (PacketStreamS2M True, Nothing)) 127 | stripPaddingT _ Strip{_buffer = f} (Just inPkt, _) = 128 | (nextSt, (PacketStreamS2M True, Nothing)) 129 | where 130 | nextAborted = _abort f || _abort inPkt 131 | 132 | nextSt = 133 | if isJust (_last inPkt) 134 | then Counting f{_abort = nextAborted} True 0 135 | else Strip (f{_abort = nextAborted}) 136 | 137 | {- | 138 | Removes padding from packets according to some expected packet length field 139 | in the metadata. If the actual length of a packet is smaller than expected, 140 | the packet is aborted. 141 | 142 | Has one clock cycle of latency, because all M2S outputs are registered. 143 | Runs at full throughput. 144 | 145 | __NB__: @dataWidth@ /must/ be smaller than @2^p@. Because this should never 146 | occur in practice, this constraint is not enforced on the type-level. 147 | -} 148 | stripPaddingC :: 149 | forall dataWidth meta p dom. 150 | (HiddenClockResetEnable dom) => 151 | (KnownNat dataWidth) => 152 | (KnownNat p) => 153 | (NFDataX meta) => 154 | -- | Function that extracts the expected packet length from the metadata 155 | (meta -> Unsigned p) -> 156 | Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta) 157 | stripPaddingC toLength = 158 | forceResetSanity 159 | |> fromSignals (mealyB (stripPaddingT toLength) s0) 160 | where 161 | s0 = 162 | Counting 163 | { _buffer = deepErrorX "stripPaddingT: undefined initial buffer." 164 | , _valid = False 165 | , _counter = 0 166 | } 167 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/PacketStream/Routing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# OPTIONS_HADDOCK hide #-} 3 | 4 | {- | 5 | Copyright : (C) 2024, QBayLogic B.V. 6 | License : BSD2 (see the file LICENSE) 7 | Maintainer : QBayLogic B.V. 8 | 9 | Provides a packet arbiter and dispatcher, for merging and splitting packet streams. 10 | -} 11 | module Protocols.PacketStream.Routing ( 12 | packetArbiterC, 13 | packetDispatcherC, 14 | routeBy, 15 | ) where 16 | 17 | import Clash.Prelude 18 | 19 | import Protocols 20 | import Protocols.Df qualified as Df 21 | import Protocols.PacketStream.Base 22 | 23 | import Data.Bifunctor qualified as B 24 | import Data.Maybe 25 | 26 | -- | Merges multiple packet streams into one, respecting packet boundaries. 27 | packetArbiterC :: 28 | forall dataWidth sources meta dom. 29 | (HiddenClockResetEnable dom) => 30 | (KnownNat sources) => 31 | (1 <= sources) => 32 | -- | Determines the mode of arbitration. See `Df.CollectMode` 33 | Df.CollectMode -> 34 | Circuit 35 | (Vec sources (PacketStream dom dataWidth meta)) 36 | (PacketStream dom dataWidth meta) 37 | packetArbiterC mode = 38 | Circuit (B.first unbundle . mealyB go (maxBound, True) . B.first bundle) 39 | where 40 | go (i, first) (fwds, bwd@(PacketStreamS2M ack)) = ((i', continue), (bwds, fwd)) 41 | where 42 | bwds = replace i bwd (repeat (PacketStreamS2M False)) 43 | fwd = fwds !! i 44 | 45 | -- We may only switch sources if we are not currently in the middle 46 | -- of forwarding a packet. 47 | continue = case (fwd, mode) of 48 | (Nothing, Df.NoSkip) -> False 49 | (Nothing, _) -> first 50 | (Just transferIn, _) -> isJust (_last transferIn) && ack 51 | 52 | i' = case (mode, continue) of 53 | (_, False) -> i 54 | (Df.NoSkip, _) -> satSucc SatWrap i 55 | (Df.Skip, _) -> satSucc SatWrap i 56 | (Df.Parallel, _) -> 57 | -- Index of last sink with data 58 | fromMaybe maxBound 59 | $ fold @(sources - 1) (<|>) (zipWith (<$) indicesI fwds) 60 | 61 | {- | 62 | Routes packets depending on their metadata, using given routing functions. 63 | 64 | Data is sent to at most one sink, for which the dispatch function evaluates to 65 | @True@ when applied to the input metadata. If none of the predicates hold, the 66 | input packet is dropped. If more than one of the predicates hold, the sink 67 | that occurs first in the vector is picked. 68 | 69 | Sends out packets in the same clock cycle as they are received, this 70 | component has zero latency and runs at full throughput. 71 | -} 72 | packetDispatcherC :: 73 | forall dataWidth sinks meta dom. 74 | (HiddenClockResetEnable dom) => 75 | (KnownNat sinks) => 76 | -- | Dispatch function 77 | Vec sinks (meta -> Bool) -> 78 | Circuit 79 | (PacketStream dom dataWidth meta) 80 | (Vec sinks (PacketStream dom dataWidth meta)) 81 | packetDispatcherC predicates = 82 | Circuit (B.second unbundle . unbundle . fmap go . bundle . B.second bundle) 83 | where 84 | idleOtp = repeat Nothing 85 | go (Nothing, _) = (PacketStreamS2M False, idleOtp) 86 | go (Just x, bwds) = case findIndex id (zipWith ($) predicates (pure $ _meta x)) of 87 | Just i -> (bwds !! i, replace i (Just x) idleOtp) 88 | Nothing -> (PacketStreamS2M True, idleOtp) 89 | 90 | {- | 91 | Routing function for `packetDispatcherC` that matches against values with 92 | an `Eq` instance. Useful to route according to a record field. 93 | -} 94 | routeBy :: 95 | (Eq a) => 96 | (meta -> a) -> 97 | Vec sinks a -> 98 | Vec sinks (meta -> Bool) 99 | routeBy f = map $ \x -> (== x) . f 100 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Vec.hs: -------------------------------------------------------------------------------- 1 | -- | Utility functions for working with `Vec`s of `Circuit`s. 2 | module Protocols.Vec ( 3 | vecCircuits, 4 | append, 5 | append3, 6 | split, 7 | split3, 8 | zip, 9 | zip3, 10 | unzip, 11 | unzip3, 12 | concat, 13 | unconcat, 14 | ) where 15 | 16 | -- base 17 | import Data.Tuple 18 | import Prelude () 19 | 20 | -- clash-prelude 21 | import Clash.Prelude hiding (concat, split, unconcat, unzip, unzip3, zip, zip3) 22 | import Clash.Prelude qualified as C 23 | 24 | -- clash-protocols-base 25 | import Protocols.Plugin 26 | 27 | import Data.Bifunctor 28 | 29 | {- | "Bundle" together a 'Vec' of 'Circuit's into a 'Circuit' with 'Vec' input and output. 30 | The 'Circuit's all run in parallel. 31 | 32 | The inverse of 'vecCircuits' can not exist, as we can not guarantee that that the @n@th 33 | manager interface only depends on the @n@th subordinate interface. 34 | -} 35 | vecCircuits :: (C.KnownNat n) => C.Vec n (Circuit a b) -> Circuit (C.Vec n a) (C.Vec n b) 36 | vecCircuits fs = Circuit (\inps -> C.unzip $ f <$> fs <*> uncurry C.zip inps) 37 | where 38 | f (Circuit ff) = ff 39 | 40 | -- | Append two separate vectors of the same circuits into one vector of circuits 41 | append :: 42 | (C.KnownNat n0) => 43 | Circuit (C.Vec n0 circuit, C.Vec n1 circuit) (C.Vec (n0 + n1) circuit) 44 | append = Circuit (swap . bimap (uncurry (++)) splitAtI) 45 | 46 | -- | Append three separate vectors of the same circuits into one vector of circuits 47 | append3 :: 48 | (C.KnownNat n0, C.KnownNat n1, KnownNat n2) => 49 | Circuit 50 | (C.Vec n0 circuit, C.Vec n1 circuit, C.Vec n2 circuit) 51 | (C.Vec (n0 + n1 + n2) circuit) 52 | append3 = Circuit (swap . bimap (uncurry3 append3Vec) split3Vec) 53 | 54 | -- | Split a vector of circuits into two vectors of circuits. 55 | split :: 56 | (C.KnownNat n0) => 57 | Circuit (C.Vec (n0 + n1) circuit) (C.Vec n0 circuit, C.Vec n1 circuit) 58 | split = Circuit go 59 | where 60 | go ~(splitAtI -> (fwd0, fwd1), (bwd0, bwd1)) = (bwd0 ++ bwd1, (fwd0, fwd1)) 61 | 62 | -- | Split a vector of circuits into three vectors of circuits. 63 | split3 :: 64 | (C.KnownNat n0, C.KnownNat n1, C.KnownNat n2) => 65 | Circuit 66 | (C.Vec (n0 + n1 + n2) circuit) 67 | (C.Vec n0 circuit, C.Vec n1 circuit, C.Vec n2 circuit) 68 | split3 = Circuit (swap . bimap split3Vec (uncurry3 append3Vec)) 69 | 70 | {- | Transforms two vectors of circuits into a vector of tuples of circuits. 71 | Only works if the two vectors have the same length. 72 | -} 73 | zip :: 74 | (C.KnownNat n) => 75 | Circuit (C.Vec n a, C.Vec n b) (C.Vec n (a, b)) 76 | zip = Circuit (swap . bimap (uncurry C.zip) C.unzip) 77 | 78 | {- | Transforms three vectors of circuits into a vector of tuples of circuits. 79 | Only works if the three vectors have the same length. 80 | -} 81 | zip3 :: 82 | (C.KnownNat n) => 83 | Circuit (C.Vec n a, C.Vec n b, C.Vec n c) (C.Vec n (a, b, c)) 84 | zip3 = Circuit (swap . bimap (uncurry3 C.zip3) C.unzip3) 85 | 86 | -- | Unzip a vector of tuples of circuits into a tuple of vectors of circuits. 87 | unzip :: 88 | (C.KnownNat n) => 89 | Circuit (C.Vec n (a, b)) (C.Vec n a, C.Vec n b) 90 | unzip = Circuit (swap . bimap C.unzip (uncurry C.zip)) 91 | 92 | -- | Unzip a vector of 3-tuples of circuits into a 3-tuple of vectors of circuits. 93 | unzip3 :: 94 | (C.KnownNat n) => 95 | Circuit (C.Vec n (a, b, c)) (C.Vec n a, C.Vec n b, C.Vec n c) 96 | unzip3 = Circuit (swap . bimap C.unzip3 (uncurry3 C.zip3)) 97 | 98 | -- | transform a vector of vectors of circuits into a vector of circuits. 99 | concat :: 100 | (C.KnownNat n0, C.KnownNat n1) => 101 | Circuit (C.Vec n0 (C.Vec n1 circuit)) (C.Vec (n0 * n1) circuit) 102 | concat = Circuit (swap . bimap C.concat (C.unconcat SNat)) 103 | 104 | -- | transform a vector of circuits into a vector of vectors of circuits. 105 | unconcat :: 106 | (C.KnownNat n, C.KnownNat m) => 107 | SNat m -> 108 | Circuit (C.Vec (n * m) circuit) (C.Vec n (C.Vec m circuit)) 109 | unconcat SNat = Circuit (swap . bimap (C.unconcat SNat) C.concat) 110 | 111 | -- Internal utilities 112 | 113 | -- | Uncurry a function with three arguments into a function that takes a 3-tuple as argument. 114 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 115 | uncurry3 f (a, b, c) = f a b c 116 | 117 | -- Append three vectors of `a` into one vector of `a`. 118 | append3Vec :: 119 | (KnownNat n0, KnownNat n1, KnownNat n2) => 120 | C.Vec n0 a -> 121 | C.Vec n1 a -> 122 | C.Vec n2 a -> 123 | C.Vec (n0 + n1 + n2) a 124 | append3Vec v0 v1 v2 = v0 ++ v1 ++ v2 125 | 126 | -- Split a C.Vector of 3-tuples into three vectors of the same length. 127 | split3Vec :: 128 | (KnownNat n0, KnownNat n1, KnownNat n2) => 129 | C.Vec (n0 + n1 + n2) a -> 130 | (C.Vec n0 a, C.Vec n1 a, C.Vec n2 a) 131 | split3Vec v = (v0, v1, v2) 132 | where 133 | (v0, splitAtI -> (v1, v2)) = splitAtI v 134 | -------------------------------------------------------------------------------- /clash-protocols/src/Protocols/Wishbone/Standard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} 4 | 5 | -- | Circuits and utils for working with Standard mode wishbone circuits. 6 | module Protocols.Wishbone.Standard where 7 | 8 | import Clash.Prelude 9 | import Data.Bifunctor qualified as B 10 | import Protocols 11 | import Protocols.Wishbone 12 | import Prelude hiding (head, not, repeat, (!!), (&&), (||)) 13 | 14 | -- | Distribute requests amongst N slave circuits 15 | roundrobin :: 16 | forall n dom addressWidth a. 17 | ( KnownNat n 18 | , HiddenClockResetEnable dom 19 | , KnownNat addressWidth 20 | , KnownNat (BitSize a) 21 | , NFDataX a 22 | , 1 <= n 23 | ) => 24 | Circuit 25 | (Wishbone dom 'Standard addressWidth a) 26 | (Vec n (Wishbone dom 'Standard addressWidth a)) 27 | roundrobin = Circuit $ \(m2s, s2ms) -> B.first head $ fn (singleton m2s, s2ms) 28 | where 29 | Circuit fn = sharedBus selectFn 30 | selectFn (unbundle -> (mIdx, sIdx, _)) = 31 | liftA2 (,) mIdx (satSucc SatWrap <$> sIdx) 32 | 33 | {- | General-purpose shared-bus with N masters and M slaves. 34 | 35 | A selector signal is used to compute the next M-S pair. 36 | -} 37 | sharedBus :: 38 | forall n m dom addressWidth a. 39 | ( KnownNat n 40 | , KnownNat m 41 | , HiddenClockResetEnable dom 42 | , KnownNat addressWidth 43 | , KnownNat (BitSize a) 44 | , NFDataX a 45 | ) => 46 | -- | Funcion to select which M-S pair should be connected next. 47 | ( Signal 48 | dom 49 | ( Index n 50 | , Index m 51 | , Vec n (WishboneM2S addressWidth (BitSize a `DivRU` 8) a) 52 | ) -> 53 | Signal dom (Index n, Index m) 54 | ) -> 55 | Circuit 56 | (Vec n (Wishbone dom 'Standard addressWidth a)) 57 | (Vec m (Wishbone dom 'Standard addressWidth a)) 58 | sharedBus selectFn = Circuit go 59 | where 60 | go (bundle -> m2ss0, bundle -> s2ms0) = (unbundle s2ms1, unbundle m2ss1) 61 | where 62 | mIdx0 = regEn (0 :: Index n) acceptIds mIdx1 63 | sIdx0 = regEn (0 :: Index m) acceptIds sIdx1 64 | 65 | (mIdx1, sIdx1) = unbundle $ selectFn (liftA3 (,,) mIdx0 sIdx0 m2ss0) 66 | 67 | m2s = liftA2 (!!) m2ss0 mIdx0 68 | s2m = liftA2 (!!) s2ms0 sIdx0 69 | 70 | acceptIds = (not . busCycle <$> m2s) .&&. (not . lock <$> m2s) 71 | 72 | m2ss1 = liftA3 replace sIdx0 m2s $ pure (repeat emptyWishboneM2S) 73 | s2ms1 = liftA3 replace mIdx0 s2m $ pure (repeat emptyWishboneS2M) 74 | 75 | -- | Crossbar-Switch circuit, allowing to dynamically route N masters to N slaves 76 | crossbarSwitch :: 77 | forall n m dom addressWidth a. 78 | ( KnownNat n 79 | , KnownNat m 80 | , KnownDomain dom 81 | , KnownNat addressWidth 82 | , NFDataX a 83 | , KnownNat (BitSize a) 84 | ) => 85 | Circuit 86 | ( CSignal dom (Vec n (Index m)) -- route 87 | , Vec n (Wishbone dom 'Standard addressWidth a) -- masters 88 | ) 89 | (Vec m (Wishbone dom 'Standard addressWidth a)) -- slaves 90 | crossbarSwitch = Circuit go 91 | where 92 | go ((route, bundle -> m2ss0), bundle -> s2ms0) = 93 | ((pure (), unbundle s2ms1), unbundle m2ss1) 94 | where 95 | m2ss1 = scatter @_ @_ @_ @_ @0 (repeat emptyWishboneM2S) <$> route <*> m2ss0 96 | s2ms1 = gather <$> s2ms0 <*> route 97 | 98 | -- | State for making guaranteeing correct timing of responses in 'memoryWb' 99 | data MemoryDelayState = Wait | AckRead 100 | deriving (Generic, NFDataX) 101 | 102 | {- | Memory component circuit using a specific RAM function 103 | 104 | This circuit uses 'Standard' mode and only supports the classic cycle type. 105 | Because of this, the data rate is limited by the one-cycle delay of the RAM 106 | function when reading and the inserted stall-cycle. 107 | 108 | The data rate could be increased by using registered feedback cycles or 109 | by using a pipelined circuit which would eliminate one wait cycle. 110 | 111 | Since the underlying block RAM operates on values of @a@ directly, the only 112 | accepted bus selector value is 'maxBound'. All other bus selector values 113 | will cause an ERR response. 114 | 115 | TODO create pipelined memory circuit 116 | -} 117 | memoryWb :: 118 | forall dom a addressWidth. 119 | ( BitPack a 120 | , NFDataX a 121 | , KnownDomain dom 122 | , KnownNat addressWidth 123 | , HiddenClockResetEnable dom 124 | , Default a 125 | ) => 126 | ( Signal dom (BitVector addressWidth) -> 127 | Signal dom (Maybe (BitVector addressWidth, a)) -> 128 | Signal dom a 129 | ) -> 130 | Circuit (Wishbone dom 'Standard addressWidth a) () 131 | memoryWb ram = Circuit go 132 | where 133 | go (m2s, ()) = (s2m1, ()) 134 | where 135 | (readAddr, write, s2m0) = unbundle $ mealy fsm Wait m2s 136 | s2m1 = (\s2m dat -> s2m{readData = dat}) <$> s2m0 <*> readValue 137 | readValue = ram readAddr write 138 | 139 | fsm st m2s 140 | -- Manager must be active if we're in this state 141 | | AckRead <- st = (Wait, (0, Nothing, noS2M{acknowledge = True})) 142 | -- Stay in Wait for invalid transactions 143 | | isError = (Wait, (0, Nothing, noS2M{err = True})) 144 | -- write requests can be ACKed directly 145 | | isWrite = (Wait, (0, write, noS2M{acknowledge = True})) 146 | -- For read requests we go to AckRead state 147 | | isRead = (AckRead, (m2s.addr, Nothing, noS2M)) 148 | | otherwise = (Wait, (0, Nothing, noS2M)) 149 | where 150 | noS2M = emptyWishboneS2M @() 151 | managerActive = m2s.busCycle && m2s.strobe 152 | isError = managerActive && (m2s.busSelect /= maxBound) 153 | isWrite = managerActive && m2s.writeEnable 154 | isRead = managerActive && not (m2s.writeEnable) 155 | write = Just (m2s.addr, m2s.writeData) 156 | -------------------------------------------------------------------------------- /clash-protocols/src/Test/Tasty/Hedgehog/Extra.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Extras for module 'Test.Tasty.Hedgehog'. Functions in this module should be 3 | upstreamed if possible. 4 | -} 5 | module Test.Tasty.Hedgehog.Extra (testProperty) where 6 | 7 | import Data.String 8 | import Hedgehog (Property) 9 | import Test.Tasty (TestTree) 10 | import Test.Tasty.Hedgehog qualified as H 11 | import Prelude 12 | 13 | -- | Like 'Test.Tasty.Hedgehog.testProperty', but inserts correct name 14 | testProperty :: [Char] -> Property -> TestTree 15 | testProperty nm = H.testPropertyNamed testName propName 16 | where 17 | testName = fromString $ "prop " <> nm 18 | propName = fromString $ "prop_" <> nm 19 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Haxioms.hs: -------------------------------------------------------------------------------- 1 | module Tests.Haxioms where 2 | 3 | import Numeric.Natural 4 | import Prelude 5 | 6 | import Hedgehog 7 | import Hedgehog.Gen qualified as Gen 8 | import Hedgehog.Range qualified as Range 9 | 10 | import Test.Tasty 11 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 12 | import Test.Tasty.Hedgehog.Extra (testProperty) 13 | import Test.Tasty.TH (testGroupGenerator) 14 | 15 | {- | Generate a 'Natural' greater than or equal to /n/. Can generate 'Natural's 16 | up to /n+1000/. This should be enough, given that naturals in this module are 17 | used in proofs. 18 | -} 19 | genNatural :: Natural -> Gen Natural 20 | genNatural min_ = Gen.integral (Range.linear min_ (1000 + min_)) 21 | 22 | -- | Like 'DivRU', but at term-level. 23 | divRU :: Natural -> Natural -> Natural 24 | divRU dividend divider = 25 | case dividend `divMod` divider of 26 | (n, 0) -> n 27 | (n, _) -> n + 1 28 | 29 | {- | Test whether the following equation holds: 30 | 31 | DivRU (a * b) b ~ a 32 | 33 | Given: 34 | 35 | 1 <= b 36 | 37 | Tests: 'Data.Constraint.Nat.Extra.cancelMulDiv'. 38 | -} 39 | prop_cancelMulDiv :: Property 40 | prop_cancelMulDiv = property $ do 41 | a <- forAll (genNatural 0) 42 | b <- forAll (genNatural 1) 43 | divRU (a * b) b === a 44 | 45 | {- | Test whether the following equation holds: 46 | 47 | Mod a b + 1 <= b 48 | 49 | Given: 50 | 51 | 1 <= b 52 | 53 | Tests: 'Data.Constraint.Nat.Extra.leModulusDivisor'. 54 | -} 55 | prop_leModulusDivisor :: Property 56 | prop_leModulusDivisor = property $ do 57 | a <- forAll (genNatural 0) 58 | b <- forAll (genNatural 1) 59 | assert (a `mod` b + 1 <= b) 60 | 61 | {- | Test whether the following equation holds: 62 | 63 | 1 <= DivRU a b 64 | 65 | Given: 66 | 67 | 1 <= a, 1 <= b 68 | 69 | Tests: 'Data.Constraint.Nat.Extra.strictlyPositiveDivRu'. 70 | -} 71 | prop_strictlyPositiveDivRu :: Property 72 | prop_strictlyPositiveDivRu = property $ do 73 | a <- forAll (genNatural 1) 74 | b <- forAll (genNatural 1) 75 | assert (1 <= divRU a b) 76 | 77 | {- | Test whether the following equation holds: 78 | 79 | b <= a * DivRU b a 80 | 81 | Given: 82 | 83 | 1 <= a 84 | 85 | Tests: 'Data.Constraint.Nat.Extra.leTimesDivRu'. 86 | -} 87 | prop_leTimesDivRu :: Property 88 | prop_leTimesDivRu = property $ do 89 | a <- forAll (genNatural 1) 90 | b <- forAll (genNatural 0) 91 | assert (b <= a * divRU b a) 92 | 93 | {- | Test whether the following equation holds: 94 | 95 | a * DivRU b a ~ b + Mod (a - Mod b a) a 96 | 97 | Given: 98 | 99 | 1 <= a 100 | 101 | Tests: 'Data.Constraint.Nat.Extra.eqTimesDivRu'. 102 | -} 103 | prop_eqTimesDivRu :: Property 104 | prop_eqTimesDivRu = property $ do 105 | a <- forAll (genNatural 1) 106 | b <- forAll (genNatural 0) 107 | a * (b `divRU` a) === b + (a - b `mod` a) `mod` a 108 | 109 | tests :: TestTree 110 | tests = 111 | localOption (mkTimeout 10_000_000 {- 10 seconds -}) $ 112 | localOption 113 | (HedgehogTestLimit (Just 100_000)) 114 | $(testGroupGenerator) 115 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols.hs: -------------------------------------------------------------------------------- 1 | module Tests.Protocols (tests, main) where 2 | 3 | import Test.Tasty 4 | import Tests.Protocols.Avalon qualified 5 | import Tests.Protocols.Axi4 qualified 6 | import Tests.Protocols.Df qualified 7 | import Tests.Protocols.DfConv qualified 8 | import Tests.Protocols.PacketStream qualified 9 | import Tests.Protocols.Vec qualified 10 | import Tests.Protocols.Wishbone qualified 11 | 12 | tests :: TestTree 13 | tests = 14 | testGroup 15 | "Protocols" 16 | [ Tests.Protocols.Df.tests 17 | , Tests.Protocols.DfConv.tests 18 | , Tests.Protocols.Avalon.tests 19 | , Tests.Protocols.Axi4.tests 20 | , Tests.Protocols.PacketStream.tests 21 | , Tests.Protocols.Wishbone.tests 22 | , Tests.Protocols.Vec.tests 23 | ] 24 | 25 | main :: IO () 26 | main = defaultMain tests 27 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/Avalon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Tests.Protocols.Avalon where 4 | 5 | -- base 6 | import Prelude 7 | 8 | -- clash-prelude 9 | import Clash.Prelude qualified as C 10 | 11 | -- extra 12 | import Data.Proxy (Proxy (..)) 13 | 14 | -- hedgehog 15 | import Hedgehog 16 | import Hedgehog.Gen qualified as Gen 17 | 18 | -- tasty 19 | import Test.Tasty 20 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 21 | import Test.Tasty.Hedgehog.Extra (testProperty) 22 | import Test.Tasty.TH (testGroupGenerator) 23 | 24 | -- clash-protocols (me!) 25 | import Protocols 26 | import Protocols.Avalon.MemMap 27 | import Protocols.Avalon.Stream 28 | import Protocols.DfConv qualified as DfConv 29 | import Protocols.Hedgehog 30 | import Protocols.Internal 31 | 32 | -- tests 33 | 34 | import Tests.Protocols.Df qualified as DfTest 35 | import Util 36 | 37 | --------------------------------------------------------------- 38 | ---------------------------- TESTS ---------------------------- 39 | --------------------------------------------------------------- 40 | 41 | type SharedConfig = 42 | 'AvalonMmSharedConfig 2 'True 'True 2 'True 'True 2 'True 2 'True 'True 'True 43 | type ManagerConfig = 44 | 'AvalonMmManagerConfig 'False 'False 'False SharedConfig 45 | type SubordinateConfig = 46 | 'AvalonMmSubordinateConfig 47 | 'True 48 | 'True 49 | 'True 50 | 'False 51 | 'True 52 | 'False 53 | 'False 54 | 'False 55 | 'False 56 | SharedConfig 57 | 58 | genWriteImpt :: Gen (AvalonWriteImpt 'True SharedConfig) 59 | genWriteImpt = 60 | AvalonWriteImpt 61 | <$> (toKeepType <$> Gen.enumBounded) 62 | <*> (toKeepType <$> Gen.enumBounded) 63 | <*> (toKeepType <$> Gen.enumBounded) 64 | <*> pure (toKeepType 1) 65 | 66 | genReadReqImpt :: Gen (AvalonReadReqImpt 'True SharedConfig) 67 | genReadReqImpt = 68 | AvalonReadReqImpt 69 | <$> (toKeepType <$> Gen.enumBounded) 70 | <*> (toKeepType <$> Gen.enumBounded) 71 | <*> pure (toKeepType 1) 72 | 73 | genReadImpt :: Gen (AvalonReadImpt SharedConfig) 74 | genReadImpt = 75 | AvalonReadImpt 76 | <$> (toKeepType <$> Gen.enumBounded) 77 | <*> (toKeepType <$> Gen.enumBounded) 78 | 79 | readReqImpt :: AvalonReadReqImpt 'True SharedConfig 80 | readReqImpt = 81 | AvalonReadReqImpt 82 | { rri_addr = toKeepType 0 83 | , rri_byteEnable = toKeepType 0 84 | , rri_burstCount = toKeepType 1 85 | } 86 | 87 | readImpt :: AvalonReadImpt SharedConfig 88 | readImpt = 89 | AvalonReadImpt 90 | { ri_readData = toKeepType 0 91 | , ri_endOfPacket = toKeepType False 92 | } 93 | 94 | -- feed ReadImpt's to a manager-to-subordinate converter, and see that the fwd 95 | -- data is preserved 96 | prop_avalon_convert_manager_subordinate :: Property 97 | prop_avalon_convert_manager_subordinate = 98 | DfTest.idWithModelDf 99 | defExpectOptions 100 | (DfTest.genData $ (Left <$> genReadReqImpt) C.<|> (Right <$> genWriteImpt)) 101 | id 102 | ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $ 103 | DfConv.dfConvTestBench 104 | Proxy 105 | Proxy 106 | (repeat True) 107 | (repeat (Just readImpt)) 108 | ckt 109 | ) 110 | where 111 | ckt :: 112 | (C.HiddenClockResetEnable dom) => 113 | Circuit 114 | (AvalonMmManager dom ManagerConfig) 115 | (AvalonMmSubordinate dom 0 SubordinateConfig) 116 | ckt = DfConv.convert Proxy Proxy 117 | 118 | -- feed ReadReqImpt's to a manager-to-subordinate converter, and see that the 119 | -- bwd data is preserved 120 | prop_avalon_convert_manager_subordinate_rev :: Property 121 | prop_avalon_convert_manager_subordinate_rev = 122 | DfTest.idWithModelDf 123 | defExpectOptions 124 | (DfTest.genData genReadImpt) 125 | id 126 | ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $ 127 | DfConv.dfConvTestBenchRev 128 | Proxy 129 | Proxy 130 | (repeat (Just $ Left readReqImpt)) 131 | (repeat True) 132 | ckt 133 | ) 134 | where 135 | ckt :: 136 | (C.HiddenClockResetEnable dom) => 137 | Circuit 138 | (AvalonMmManager dom ManagerConfig) 139 | (AvalonMmSubordinate dom 0 SubordinateConfig) 140 | ckt = DfConv.convert Proxy Proxy 141 | 142 | -- feed ReadImpt's to a subordinate-to-manager converter, and see that the fwd 143 | -- data is preserved 144 | prop_avalon_convert_subordinate_manager :: Property 145 | prop_avalon_convert_subordinate_manager = 146 | DfTest.idWithModelDf 147 | defExpectOptions 148 | (DfTest.genData $ (Left <$> genReadReqImpt) C.<|> (Right <$> genWriteImpt)) 149 | id 150 | ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $ 151 | DfConv.dfConvTestBench 152 | Proxy 153 | Proxy 154 | (repeat True) 155 | (repeat (Just readImpt)) 156 | ckt 157 | ) 158 | where 159 | ckt :: 160 | (C.HiddenClockResetEnable dom) => 161 | Circuit 162 | (AvalonMmSubordinate dom 0 SubordinateConfig) 163 | (AvalonMmManager dom ManagerConfig) 164 | ckt = DfConv.convert Proxy Proxy 165 | 166 | -- feed ReadReqImpt's to a subordinate-to-manager converter, and see that the 167 | -- bwd data is preserved 168 | prop_avalon_convert_subordinate_manager_rev :: Property 169 | prop_avalon_convert_subordinate_manager_rev = 170 | DfTest.idWithModelDf 171 | defExpectOptions 172 | (DfTest.genData genReadImpt) 173 | id 174 | ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $ 175 | DfConv.dfConvTestBenchRev 176 | Proxy 177 | Proxy 178 | (repeat (Just $ Left readReqImpt)) 179 | (repeat True) 180 | ckt 181 | ) 182 | where 183 | ckt :: 184 | (C.HiddenClockResetEnable dom) => 185 | Circuit 186 | (AvalonMmSubordinate dom 0 SubordinateConfig) 187 | (AvalonMmManager dom ManagerConfig) 188 | ckt = DfConv.convert Proxy Proxy 189 | 190 | -- also test out the DfConv instance for AvalonStream 191 | 192 | prop_avalon_stream_fifo_id :: Property 193 | prop_avalon_stream_fifo_id = 194 | propWithModelSingleDomain 195 | @C.System 196 | defExpectOptions 197 | (DfTest.genData genInfo) 198 | (C.exposeClockResetEnable id) 199 | (C.exposeClockResetEnable @C.System ckt) 200 | (\a b -> tally a === tally b) 201 | where 202 | ckt :: 203 | (C.HiddenClockResetEnable dom) => 204 | Circuit 205 | (AvalonStream dom ('AvalonStreamConfig 2 2 'True 'True 2 0) Int) 206 | (AvalonStream dom ('AvalonStreamConfig 2 2 'True 'True 2 0) Int) 207 | ckt = DfConv.fifo Proxy Proxy (C.SNat @10) 208 | 209 | genInfo = 210 | AvalonStreamM2S 211 | <$> DfTest.genSmallInt 212 | <*> Gen.enumBounded 213 | <*> Gen.enumBounded 214 | <*> (toKeepType <$> Gen.enumBounded) 215 | <*> (toKeepType <$> Gen.enumBounded) 216 | <*> Gen.enumBounded 217 | 218 | tests :: TestTree 219 | tests = 220 | -- TODO: Move timeout option to hedgehog for better error messages. 221 | -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@?? 222 | localOption (mkTimeout 12_000_000 {- 12 seconds -}) $ 223 | localOption 224 | (HedgehogTestLimit (Just 1000)) 225 | $(testGroupGenerator) 226 | 227 | main :: IO () 228 | main = defaultMain tests 229 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/DfConv.hs: -------------------------------------------------------------------------------- 1 | -- TODO: Fix warnings introduced by GHC 9.2 w.r.t. incomplete lazy pattern matches 2 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 3 | 4 | module Tests.Protocols.DfConv where 5 | 6 | -- base 7 | 8 | import Data.Maybe (fromMaybe) 9 | import Prelude 10 | 11 | -- clash-prelude 12 | import Clash.Prelude qualified as C 13 | 14 | -- list 15 | import Data.List (mapAccumL, partition, transpose) 16 | 17 | -- containers 18 | import Data.HashMap.Strict qualified as HashMap 19 | 20 | -- extra 21 | import Data.Proxy (Proxy (..)) 22 | 23 | -- hedgehog 24 | import Hedgehog 25 | import Hedgehog.Gen qualified as Gen 26 | import Hedgehog.Range qualified as Range 27 | 28 | -- tasty 29 | import Test.Tasty 30 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 31 | import Test.Tasty.Hedgehog.Extra (testProperty) 32 | import Test.Tasty.TH (testGroupGenerator) 33 | 34 | -- clash-protocols (me!) 35 | import Protocols 36 | import Protocols.DfConv qualified as DfConv 37 | import Protocols.Hedgehog 38 | import Protocols.Internal 39 | 40 | -- tests 41 | 42 | import Tests.Protocols.Df qualified as DfTest 43 | import Util 44 | 45 | --------------------------------------------------------------- 46 | ---------------------------- TESTS ---------------------------- 47 | --------------------------------------------------------------- 48 | 49 | -- test a small selection of dflike functions on df 50 | -- this is moreso to test @instance DfConv Df@, 51 | -- as well as @dfToDfConvInp@ etc, 52 | -- rather than the functions themselves, 53 | -- since we know they work from @Tests.Protocols.Df@ 54 | 55 | prop_df_map_inc :: Property 56 | prop_df_map_inc = 57 | DfTest.idWithModelDf' 58 | (fmap (+ 1)) 59 | (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt) 60 | where 61 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int) 62 | ckt = DfConv.map Proxy Proxy (+ 1) 63 | 64 | prop_df_filter_over_5 :: Property 65 | prop_df_filter_over_5 = 66 | DfTest.idWithModelDf' 67 | (filter (> 5)) 68 | (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt) 69 | where 70 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int) 71 | ckt = DfConv.filter Proxy Proxy (> 5) 72 | 73 | prop_df_mapmaybe_inc_over_5 :: Property 74 | prop_df_mapmaybe_inc_over_5 = 75 | DfTest.idWithModelDf' 76 | (map (+ 1) . filter (> 5)) 77 | (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt) 78 | where 79 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int) 80 | ckt = DfConv.mapMaybe Proxy Proxy (\n -> if n > 5 then Just (n + 1) else Nothing) 81 | 82 | prop_df_zipwith_add :: Property 83 | prop_df_zipwith_add = 84 | idWithModel 85 | defExpectOptions 86 | ( do 87 | as <- DfTest.genData DfTest.genSmallInt 88 | bs <- DfTest.genData DfTest.genSmallInt 89 | let n = min (length as) (length bs) 90 | pure (take n as, take n bs) 91 | ) 92 | (uncurry (zipWith (+))) 93 | (C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen ckt) 94 | where 95 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int, Df dom Int) (Df dom Int) 96 | ckt = DfConv.zipWith (Proxy, Proxy) Proxy (+) 97 | 98 | prop_df_fanout1 :: Property 99 | prop_df_fanout1 = 100 | idWithModelSingleDomain 101 | @C.System 102 | defExpectOptions 103 | (DfTest.genData DfTest.genSmallInt) 104 | (C.exposeClockResetEnable C.repeat) 105 | (C.exposeClockResetEnable ckt) 106 | where 107 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (C.Vec 1 (Df dom Int)) 108 | ckt = DfConv.fanout Proxy Proxy 109 | 110 | prop_df_fanout2 :: Property 111 | prop_df_fanout2 = 112 | idWithModelSingleDomain 113 | @C.System 114 | defExpectOptions 115 | (DfTest.genData DfTest.genSmallInt) 116 | (C.exposeClockResetEnable C.repeat) 117 | (C.exposeClockResetEnable ckt) 118 | where 119 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (C.Vec 2 (Df dom Int)) 120 | ckt = DfConv.fanout Proxy Proxy 121 | 122 | prop_df_fanout7 :: Property 123 | prop_df_fanout7 = 124 | idWithModelSingleDomain 125 | @C.System 126 | defExpectOptions 127 | (DfTest.genData DfTest.genSmallInt) 128 | (C.exposeClockResetEnable C.repeat) 129 | (C.exposeClockResetEnable ckt) 130 | where 131 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (C.Vec 7 (Df dom Int)) 132 | ckt = DfConv.fanout Proxy Proxy 133 | 134 | prop_df_partition :: Property 135 | prop_df_partition = 136 | idWithModelSingleDomain 137 | @C.System 138 | defExpectOptions 139 | (DfTest.genData DfTest.genSmallInt) 140 | (C.exposeClockResetEnable $ partition (> 5)) 141 | (C.exposeClockResetEnable ckt) 142 | where 143 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int, Df dom Int) 144 | ckt = DfConv.partition Proxy (Proxy, Proxy) (> 5) 145 | 146 | prop_df_fanin :: Property 147 | prop_df_fanin = 148 | idWithModelSingleDomain 149 | @C.System 150 | defExpectOptions 151 | (DfTest.genVecData DfTest.genSmallInt) 152 | (C.exposeClockResetEnable $ map sum . transpose . C.toList) 153 | (C.exposeClockResetEnable ckt) 154 | where 155 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (C.Vec 3 (Df dom Int)) (Df dom Int) 156 | ckt = DfConv.fanin Proxy Proxy (+) 157 | 158 | prop_df_fifo_id :: Property 159 | prop_df_fifo_id = 160 | propWithModelSingleDomain 161 | @C.System 162 | defExpectOptions 163 | (DfTest.genData DfTest.genSmallInt) 164 | (C.exposeClockResetEnable id) 165 | (C.exposeClockResetEnable @C.System ckt) 166 | (\a b -> tally a === tally b) 167 | where 168 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int) 169 | ckt = DfConv.fifo Proxy Proxy (C.SNat @10) 170 | 171 | prop_select :: Property 172 | prop_select = 173 | idWithModel 174 | defExpectOptions 175 | goGen 176 | (snd . uncurry (mapAccumL goModel)) 177 | (C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen ckt) 178 | where 179 | ckt :: 180 | (C.HiddenClockResetEnable dom) => 181 | Circuit (C.Vec 3 (Df dom Int), Df dom (C.Index 3)) (Df dom Int) 182 | ckt = DfConv.select (Proxy @(Df _ Int), Proxy @(Df _ (C.Index 3))) (Proxy @(Df _ Int)) 183 | 184 | goModel :: C.Vec 3 [Int] -> C.Index 3 -> (C.Vec 3 [Int], Int) 185 | goModel vec ix = let (i : is) = vec C.!! ix in (C.replace ix is vec, i) 186 | 187 | goGen :: Gen (C.Vec 3 [Int], [C.Index 3]) 188 | goGen = do 189 | n <- DfTest.genSmallInt 190 | ixs <- Gen.list (Range.singleton n) Gen.enumBounded 191 | let tall i = fromMaybe 0 (HashMap.lookup i (tally ixs)) 192 | dats <- mapM (\i -> Gen.list (Range.singleton (tall i)) DfTest.genSmallInt) C.indicesI 193 | pure (dats, ixs) 194 | 195 | -- test out instance DfConv (Reverse a) 196 | 197 | prop_reverse_df_convert_id :: Property 198 | prop_reverse_df_convert_id = 199 | DfTest.idWithModelDf' 200 | id 201 | (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt) 202 | where 203 | ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int) 204 | ckt = 205 | coerceCircuit $ 206 | reverseCircuit $ 207 | DfConv.convert (Proxy @(Reverse (Df _ _))) (Proxy @(Reverse (Df _ _))) 208 | 209 | -- test out the test bench 210 | prop_test_bench_id :: Property 211 | prop_test_bench_id = 212 | DfTest.idWithModelDf 213 | defExpectOptions 214 | (DfTest.genData DfTest.genSmallInt) 215 | id 216 | ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $ 217 | DfConv.dfConvTestBench 218 | Proxy 219 | Proxy 220 | (repeat True) 221 | (repeat (Just 0)) 222 | ckt 223 | ) 224 | where 225 | ckt :: 226 | (C.HiddenClockResetEnable dom) => 227 | Circuit 228 | (Df dom Int, Reverse (Df dom Int)) 229 | (Df dom Int, Reverse (Df dom Int)) 230 | ckt = DfConv.convert Proxy Proxy 231 | 232 | prop_test_bench_rev_id :: Property 233 | prop_test_bench_rev_id = 234 | DfTest.idWithModelDf 235 | defExpectOptions 236 | (DfTest.genData DfTest.genSmallInt) 237 | id 238 | ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $ 239 | DfConv.dfConvTestBenchRev 240 | Proxy 241 | Proxy 242 | (repeat (Just 0)) 243 | (repeat True) 244 | ckt 245 | ) 246 | where 247 | ckt :: 248 | (C.HiddenClockResetEnable dom) => 249 | Circuit 250 | (Df dom Int, Reverse (Df dom Int)) 251 | (Df dom Int, Reverse (Df dom Int)) 252 | ckt = DfConv.convert Proxy Proxy 253 | 254 | tests :: TestTree 255 | tests = 256 | -- TODO: Move timeout option to hedgehog for better error messages. 257 | -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@?? 258 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) $ 259 | localOption 260 | (HedgehogTestLimit (Just 1000)) 261 | $(testGroupGenerator) 262 | 263 | main :: IO () 264 | main = defaultMain tests 265 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream.hs: -------------------------------------------------------------------------------- 1 | module Tests.Protocols.PacketStream (tests) where 2 | 3 | import Test.Tasty 4 | 5 | import Tests.Protocols.PacketStream.AsyncFifo qualified 6 | import Tests.Protocols.PacketStream.Base qualified 7 | import Tests.Protocols.PacketStream.Converters qualified 8 | import Tests.Protocols.PacketStream.Depacketizers qualified 9 | import Tests.Protocols.PacketStream.PacketFifo qualified 10 | import Tests.Protocols.PacketStream.Packetizers qualified 11 | import Tests.Protocols.PacketStream.Padding qualified 12 | import Tests.Protocols.PacketStream.Routing qualified 13 | 14 | tests :: TestTree 15 | tests = 16 | testGroup 17 | "PacketStream" 18 | [ Tests.Protocols.PacketStream.AsyncFifo.tests 19 | , Tests.Protocols.PacketStream.Base.tests 20 | , Tests.Protocols.PacketStream.Converters.tests 21 | , Tests.Protocols.PacketStream.Depacketizers.tests 22 | , Tests.Protocols.PacketStream.PacketFifo.tests 23 | , Tests.Protocols.PacketStream.Packetizers.tests 24 | , Tests.Protocols.PacketStream.Padding.tests 25 | , Tests.Protocols.PacketStream.Routing.tests 26 | ] 27 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/AsyncFifo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Tests.Protocols.PacketStream.AsyncFifo where 4 | 5 | import Clash.Prelude 6 | 7 | import Hedgehog (Property) 8 | import Hedgehog.Gen qualified as Gen 9 | import Hedgehog.Range qualified as Range 10 | 11 | import Test.Tasty (TestTree, localOption, mkTimeout) 12 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 13 | import Test.Tasty.Hedgehog.Extra (testProperty) 14 | import Test.Tasty.TH (testGroupGenerator) 15 | 16 | import Protocols.Hedgehog 17 | import Protocols.PacketStream.AsyncFifo (asyncFifoC) 18 | import Protocols.PacketStream.Hedgehog 19 | 20 | createDomain 21 | vSystem 22 | { vName = "TestDom50" 23 | , vPeriod = 20_000 24 | , vActiveEdge = Rising 25 | , vResetKind = Asynchronous 26 | , vInitBehavior = Unknown 27 | , vResetPolarity = ActiveHigh 28 | } 29 | 30 | createDomain 31 | vSystem 32 | { vName = "TestDom125" 33 | , vPeriod = 8_000 34 | , vActiveEdge = Rising 35 | , vResetKind = Asynchronous 36 | , vInitBehavior = Unknown 37 | , vResetPolarity = ActiveHigh 38 | } 39 | 40 | clk50 :: Clock TestDom50 41 | clk50 = clockGen 42 | 43 | clk125 :: Clock TestDom125 44 | clk125 = clockGen 45 | 46 | -- Assert the reset for a different amount of cycles in each domain 47 | -- to properly test the async fifo. 48 | rst50 :: Reset TestDom50 49 | rst50 = resetGenN d30 50 | 51 | rst125 :: Reset TestDom125 52 | rst125 = resetGenN d40 53 | 54 | en50 :: Enable TestDom50 55 | en50 = enableGen 56 | 57 | en125 :: Enable TestDom125 58 | en125 = enableGen 59 | 60 | generateAsyncFifoIdProp :: 61 | forall (wDom :: Domain) (rDom :: Domain). 62 | (KnownDomain wDom, KnownDomain rDom) => 63 | Clock wDom -> 64 | Reset wDom -> 65 | Enable wDom -> 66 | Clock rDom -> 67 | Reset rDom -> 68 | Enable rDom -> 69 | Property 70 | generateAsyncFifoIdProp wClk wRst wEn rClk rRst rEn = 71 | idWithModel 72 | defExpectOptions 73 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 30))) 74 | id 75 | (asyncFifoC @wDom @rDom @4 @1 @Int d4 wClk wRst wEn rClk rRst rEn) 76 | 77 | {- | The async FIFO circuit should forward all of its input data without loss and without producing extra data. 78 | This property tests whether this is true, when the clock of the writer and reader is equally fast (50 MHz). 79 | -} 80 | prop_asyncfifo_writer_speed_equal_to_reader_id :: Property 81 | prop_asyncfifo_writer_speed_equal_to_reader_id = generateAsyncFifoIdProp clk50 rst50 en50 clk50 rst50 en50 82 | 83 | {- | The async FIFO circuit should forward all of its input data without loss and without producing extra data. 84 | This property tests whether this is true, when the clock of the writer (50 MHz) is slower than the clock of the reader (125 MHz). 85 | -} 86 | prop_asyncfifo_writer_speed_slower_than_reader_id :: Property 87 | prop_asyncfifo_writer_speed_slower_than_reader_id = generateAsyncFifoIdProp clk50 rst50 en50 clk125 rst125 en125 88 | 89 | {- | The async FIFO circuit should forward all of its input data without loss and without producing extra data. 90 | This property tests whether this is true, when the clock of the writer (125 MHz) is faster than the clock of the reader (50 MHz). 91 | -} 92 | prop_asyncfifo_writer_speed_faster_than_reader_id :: Property 93 | prop_asyncfifo_writer_speed_faster_than_reader_id = generateAsyncFifoIdProp clk125 rst125 en125 clk50 rst50 en50 94 | 95 | tests :: TestTree 96 | tests = 97 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) $ 98 | localOption 99 | (HedgehogTestLimit (Just 100)) 100 | $(testGroupGenerator) 101 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Tests.Protocols.PacketStream.Base ( 4 | tests, 5 | ) where 6 | 7 | import Clash.Prelude 8 | 9 | import Data.List qualified as L 10 | import Data.List.Extra (unsnoc) 11 | 12 | import Hedgehog (Property) 13 | import Hedgehog.Gen qualified as Gen 14 | import Hedgehog.Range qualified as Range 15 | 16 | import Test.Tasty (TestTree, localOption, mkTimeout) 17 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 18 | import Test.Tasty.Hedgehog.Extra (testProperty) 19 | import Test.Tasty.TH (testGroupGenerator) 20 | 21 | import Protocols.Hedgehog 22 | import Protocols.PacketStream.Base 23 | import Protocols.PacketStream.Hedgehog 24 | 25 | prop_strip_trailing_empty :: Property 26 | prop_strip_trailing_empty = 27 | idWithModelSingleDomain 28 | @System 29 | defExpectOptions 30 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10))) 31 | (exposeClockResetEnable model') 32 | (exposeClockResetEnable (stripTrailingEmptyC @1 @Char)) 33 | where 34 | model' packets = L.concatMap model (chunkByPacket packets) 35 | 36 | model :: [PacketStreamM2S 1 Char] -> [PacketStreamM2S 1 Char] 37 | model packet = case unsnoc packet of 38 | Nothing -> [] 39 | Just (xs, l) -> case unsnoc xs of 40 | -- Preserve packets that consist of a single zero-byte transfer. 41 | Nothing -> [l] 42 | Just (ys, l2) -> 43 | if _last l == Just 0 44 | then ys L.++ [l2{_last = Just maxBound, _abort = _abort l2 || _abort l}] 45 | else packet 46 | 47 | tests :: TestTree 48 | tests = 49 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 50 | $ localOption 51 | (HedgehogTestLimit (Just 500)) 52 | $(testGroupGenerator) 53 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/Converters.hs: -------------------------------------------------------------------------------- 1 | module Tests.Protocols.PacketStream.Converters ( 2 | tests, 3 | ) where 4 | 5 | import Clash.Prelude 6 | 7 | import Hedgehog (Property) 8 | import Hedgehog.Gen qualified as Gen 9 | import Hedgehog.Range qualified as Range 10 | 11 | import Test.Tasty 12 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 13 | import Test.Tasty.Hedgehog.Extra (testProperty) 14 | import Test.Tasty.TH (testGroupGenerator) 15 | 16 | import Protocols.Hedgehog 17 | import Protocols.PacketStream.Converters 18 | import Protocols.PacketStream.Hedgehog 19 | 20 | generateUpConverterProperty :: 21 | forall (dwIn :: Nat) (n :: Nat). 22 | (1 <= dwIn) => 23 | (1 <= n) => 24 | (1 <= dwIn * n) => 25 | SNat dwIn -> 26 | SNat n -> 27 | Property 28 | generateUpConverterProperty SNat SNat = 29 | idWithModelSingleDomain 30 | defExpectOptions 31 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 20))) 32 | (exposeClockResetEnable (upConvert . downConvert)) 33 | (exposeClockResetEnable @System (upConverterC @dwIn @n @Int)) 34 | 35 | generateDownConverterProperty :: 36 | forall (dwOut :: Nat) (n :: Nat). 37 | (1 <= dwOut) => 38 | (1 <= n) => 39 | (1 <= dwOut * n) => 40 | SNat dwOut -> 41 | SNat n -> 42 | Property 43 | generateDownConverterProperty SNat SNat = 44 | idWithModelSingleDomain 45 | defExpectOptions{eoSampleMax = 1000} 46 | (genPackets 1 8 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10))) 47 | (exposeClockResetEnable (upConvert . downConvert)) 48 | (exposeClockResetEnable @System (downConverterC @dwOut @n @Int)) 49 | 50 | prop_upConverter3to9 :: Property 51 | prop_upConverter3to9 = generateUpConverterProperty d3 d3 52 | 53 | prop_upConverter4to8 :: Property 54 | prop_upConverter4to8 = generateUpConverterProperty d4 d2 55 | 56 | prop_upConverter3to6 :: Property 57 | prop_upConverter3to6 = generateUpConverterProperty d3 d2 58 | 59 | prop_upConverter2to4 :: Property 60 | prop_upConverter2to4 = generateUpConverterProperty d2 d2 61 | 62 | prop_upConverter1to4 :: Property 63 | prop_upConverter1to4 = generateUpConverterProperty d1 d4 64 | 65 | prop_upConverter1to2 :: Property 66 | prop_upConverter1to2 = generateUpConverterProperty d1 d2 67 | 68 | prop_upConverter1to1 :: Property 69 | prop_upConverter1to1 = generateUpConverterProperty d1 d1 70 | 71 | prop_downConverter9to3 :: Property 72 | prop_downConverter9to3 = generateDownConverterProperty d3 d3 73 | 74 | prop_downConverter8to4 :: Property 75 | prop_downConverter8to4 = generateDownConverterProperty d4 d2 76 | 77 | prop_downConverter6to3 :: Property 78 | prop_downConverter6to3 = generateDownConverterProperty d3 d2 79 | 80 | prop_downConverter4to2 :: Property 81 | prop_downConverter4to2 = generateDownConverterProperty d2 d2 82 | 83 | prop_downConverter4to1 :: Property 84 | prop_downConverter4to1 = generateDownConverterProperty d1 d4 85 | 86 | prop_downConverter2to1 :: Property 87 | prop_downConverter2to1 = generateDownConverterProperty d1 d2 88 | 89 | prop_downConverter1to1 :: Property 90 | prop_downConverter1to1 = generateDownConverterProperty d1 d1 91 | 92 | tests :: TestTree 93 | tests = 94 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) $ 95 | localOption 96 | (HedgehogTestLimit (Just 500)) 97 | $(testGroupGenerator) 98 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/Depacketizers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Tests.Protocols.PacketStream.Depacketizers ( 4 | tests, 5 | ) where 6 | 7 | import Clash.Prelude 8 | 9 | import Hedgehog (Gen, Property) 10 | import Hedgehog.Gen qualified as Gen 11 | import Hedgehog.Range qualified as Range 12 | 13 | import Test.Tasty 14 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 15 | 16 | import Test.Tasty.Hedgehog.Extra (testProperty) 17 | import Test.Tasty.TH (testGroupGenerator) 18 | 19 | import Protocols 20 | import Protocols.Hedgehog 21 | import Protocols.PacketStream.Base 22 | import Protocols.PacketStream.Depacketizers 23 | import Protocols.PacketStream.Hedgehog 24 | 25 | {- | 26 | Test @depacketizerC@ with varying data width, number of bytes in the 27 | header, input metadata, and output metadata. 28 | -} 29 | depacketizerPropGen :: 30 | forall 31 | (metaIn :: Type) 32 | (metaOut :: Type) 33 | (dataWidth :: Nat) 34 | (headerBytes :: Nat). 35 | (1 <= dataWidth) => 36 | (1 <= headerBytes) => 37 | (TestType metaIn) => 38 | (TestType metaOut) => 39 | SNat dataWidth -> 40 | SNat headerBytes -> 41 | Gen metaIn -> 42 | (Vec headerBytes (BitVector 8) -> metaIn -> metaOut) -> 43 | Property 44 | depacketizerPropGen SNat SNat metaGen toMetaOut = 45 | idWithModelSingleDomain 46 | @System 47 | defExpectOptions{eoSampleMax = 1000, eoStopAfterEmpty = 1000} 48 | (genPackets 1 4 (genValidPacket defPacketOptions metaGen (Range.linear 0 30))) 49 | (exposeClockResetEnable (depacketizerModel toMetaOut)) 50 | (exposeClockResetEnable ckt) 51 | where 52 | ckt :: 53 | (HiddenClockResetEnable System) => 54 | Circuit 55 | (PacketStream System dataWidth metaIn) 56 | (PacketStream System dataWidth metaOut) 57 | ckt = depacketizerC toMetaOut 58 | 59 | {- | 60 | Test @depacketizeToDfC@ with varying data width, number of bytes in the 61 | header, input metadata, and output type @a@. 62 | -} 63 | depacketizeToDfPropGen :: 64 | forall 65 | (metaIn :: Type) 66 | (a :: Type) 67 | (dataWidth :: Nat) 68 | (headerBytes :: Nat). 69 | (1 <= dataWidth) => 70 | (1 <= headerBytes) => 71 | (BitPack a) => 72 | (BitSize a ~ headerBytes * 8) => 73 | (TestType a) => 74 | (TestType metaIn) => 75 | SNat dataWidth -> 76 | SNat headerBytes -> 77 | Gen metaIn -> 78 | (Vec headerBytes (BitVector 8) -> metaIn -> a) -> 79 | Property 80 | depacketizeToDfPropGen SNat SNat metaGen toOut = 81 | idWithModelSingleDomain 82 | @System 83 | defExpectOptions{eoSampleMax = 1000, eoStopAfterEmpty = 1000} 84 | (genPackets 1 10 (genValidPacket defPacketOptions metaGen (Range.linear 0 20))) 85 | (exposeClockResetEnable (depacketizeToDfModel toOut)) 86 | (exposeClockResetEnable ckt) 87 | where 88 | ckt :: 89 | (HiddenClockResetEnable System) => 90 | Circuit (PacketStream System dataWidth metaIn) (Df System a) 91 | ckt = depacketizeToDfC toOut 92 | 93 | {- | 94 | Do something interesting with both the parsed header and the input 95 | metadata for testing purposes. We just xor every byte in the parsed 96 | header with the byte in the input metadata. 97 | -} 98 | exampleToMetaOut :: 99 | Vec headerBytes (BitVector 8) -> 100 | BitVector 8 -> 101 | Vec headerBytes (BitVector 8) 102 | exampleToMetaOut hdr metaIn = map (`xor` metaIn) hdr 103 | 104 | -- | headerBytes % dataWidth ~ 0 105 | prop_const_depacketizer_d1_d14 :: Property 106 | prop_const_depacketizer_d1_d14 = 107 | depacketizerPropGen d1 d14 (pure ()) const 108 | 109 | prop_xor_depacketizer_d1_d14 :: Property 110 | prop_xor_depacketizer_d1_d14 = 111 | depacketizerPropGen d1 d14 Gen.enumBounded exampleToMetaOut 112 | 113 | -- | dataWidth < headerBytes 114 | prop_const_depacketizer_d3_d11 :: Property 115 | prop_const_depacketizer_d3_d11 = 116 | depacketizerPropGen d3 d11 (pure ()) const 117 | 118 | prop_xor_depacketizer_d3_d11 :: Property 119 | prop_xor_depacketizer_d3_d11 = 120 | depacketizerPropGen d3 d11 Gen.enumBounded exampleToMetaOut 121 | 122 | -- | dataWidth ~ header byte size 123 | prop_const_depacketizer_d7_d7 :: Property 124 | prop_const_depacketizer_d7_d7 = 125 | depacketizerPropGen d7 d7 (pure ()) const 126 | 127 | prop_xor_depacketizer_d7_d7 :: Property 128 | prop_xor_depacketizer_d7_d7 = 129 | depacketizerPropGen d7 d7 Gen.enumBounded exampleToMetaOut 130 | 131 | -- | dataWidth > header byte size 132 | prop_const_depacketizer_d5_d4 :: Property 133 | prop_const_depacketizer_d5_d4 = 134 | depacketizerPropGen d5 d4 (pure ()) const 135 | 136 | prop_xor_depacketizer_d5_d4 :: Property 137 | prop_xor_depacketizer_d5_d4 = 138 | depacketizerPropGen d5 d4 Gen.enumBounded exampleToMetaOut 139 | 140 | -- | headerBytes % dataWidth ~ 0 141 | prop_const_depacketize_to_df_d1_d14 :: Property 142 | prop_const_depacketize_to_df_d1_d14 = 143 | depacketizeToDfPropGen d1 d14 (pure ()) const 144 | 145 | prop_xor_depacketize_to_df_d1_d14 :: Property 146 | prop_xor_depacketize_to_df_d1_d14 = 147 | depacketizeToDfPropGen d1 d14 Gen.enumBounded exampleToMetaOut 148 | 149 | -- | dataWidth < headerBytes 150 | prop_const_depacketize_to_df_d3_d11 :: Property 151 | prop_const_depacketize_to_df_d3_d11 = 152 | depacketizeToDfPropGen d3 d11 (pure ()) const 153 | 154 | prop_xor_depacketize_to_df_d3_d11 :: Property 155 | prop_xor_depacketize_to_df_d3_d11 = 156 | depacketizeToDfPropGen d3 d11 Gen.enumBounded exampleToMetaOut 157 | 158 | -- | dataWidth ~ header byte size 159 | prop_const_depacketize_to_df_d7_d7 :: Property 160 | prop_const_depacketize_to_df_d7_d7 = 161 | depacketizeToDfPropGen d7 d7 (pure ()) const 162 | 163 | prop_xor_depacketize_to_df_d7_d7 :: Property 164 | prop_xor_depacketize_to_df_d7_d7 = 165 | depacketizeToDfPropGen d7 d7 Gen.enumBounded exampleToMetaOut 166 | 167 | -- | dataWidth > header byte size 168 | prop_const_depacketize_to_df_d5_d4 :: Property 169 | prop_const_depacketize_to_df_d5_d4 = 170 | depacketizeToDfPropGen d5 d4 (pure ()) const 171 | 172 | prop_xor_depacketize_to_df_d5_d4 :: Property 173 | prop_xor_depacketize_to_df_d5_d4 = 174 | depacketizeToDfPropGen d5 d4 Gen.enumBounded exampleToMetaOut 175 | 176 | tests :: TestTree 177 | tests = 178 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 179 | $ localOption 180 | (HedgehogTestLimit (Just 500)) 181 | $(testGroupGenerator) 182 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/PacketFifo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Tests.Protocols.PacketStream.PacketFifo ( 4 | tests, 5 | ) where 6 | 7 | import Clash.Prelude 8 | 9 | import Data.Int (Int16) 10 | import Data.List qualified as L 11 | 12 | import Hedgehog 13 | import Hedgehog.Gen qualified as Gen 14 | import Hedgehog.Range qualified as Range 15 | 16 | import Prelude qualified as P 17 | 18 | import Test.Tasty 19 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 20 | import Test.Tasty.Hedgehog.Extra (testProperty) 21 | import Test.Tasty.TH (testGroupGenerator) 22 | 23 | import Protocols 24 | import Protocols.Hedgehog 25 | import Protocols.PacketStream.Base 26 | import Protocols.PacketStream.Hedgehog 27 | import Protocols.PacketStream.PacketFifo 28 | 29 | -- | Drops packets that consist of more than 2^n transfers. 30 | dropBigPackets :: 31 | SNat n -> 32 | [PacketStreamM2S dataWidth meta] -> 33 | [PacketStreamM2S dataWidth meta] 34 | dropBigPackets n packets = 35 | L.concat 36 | $ L.filter 37 | (\p -> L.length p < 2 P.^ snatToInteger n) 38 | (chunkByPacket packets) 39 | 40 | -- | Test for id and proper dropping of aborted packets. 41 | prop_packet_fifo_id :: Property 42 | prop_packet_fifo_id = 43 | idWithModelSingleDomain 44 | @System 45 | defExpectOptions 46 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10))) 47 | (exposeClockResetEnable dropAbortedPackets) 48 | (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d10 d10 Backpressure)) 49 | 50 | {- | 51 | Ensure that backpressure because of a full content RAM and dropping of packets 52 | that are too big to fit in the FIFO is tested. 53 | -} 54 | prop_packet_fifo_small_buffer_id :: Property 55 | prop_packet_fifo_small_buffer_id = 56 | idWithModelSingleDomain 57 | @System 58 | defExpectOptions{eoStopAfterEmpty = 1000} 59 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 30))) 60 | (exposeClockResetEnable (dropBigPackets d3 . dropAbortedPackets)) 61 | (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d3 d5 Backpressure)) 62 | 63 | {- | 64 | Test for id using a small meta buffer to ensure backpressure using 65 | the meta buffer is tested. 66 | -} 67 | prop_packet_fifo_small_meta_buffer_id :: Property 68 | prop_packet_fifo_small_meta_buffer_id = 69 | idWithModelSingleDomain 70 | @System 71 | defExpectOptions 72 | (genPackets 1 30 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 4))) 73 | (exposeClockResetEnable dropAbortedPackets) 74 | (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d10 d2 Backpressure)) 75 | 76 | -- | test for id and proper dropping of aborted packets 77 | prop_overFlowDrop_packetFifo_id :: Property 78 | prop_overFlowDrop_packetFifo_id = 79 | idWithModelSingleDomain 80 | @System 81 | defExpectOptions{eoStopAfterEmpty = 1000} 82 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10))) 83 | (exposeClockResetEnable dropAbortedPackets) 84 | (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d10 d10 Drop)) 85 | 86 | -- | test for proper dropping when full 87 | prop_overFlowDrop_packetFifo_drop :: Property 88 | prop_overFlowDrop_packetFifo_drop = 89 | propWithModelSingleDomain 90 | @System 91 | defExpectOptions 92 | -- make sure the timeout is long as the packetFifo can be quiet for a while while dropping 93 | (liftA3 (\a b c -> a L.++ b L.++ c) genSmall genBig genSmall) 94 | (exposeClockResetEnable id) 95 | (exposeClockResetEnable (packetFifoC @_ @4 @Int16 d3 d5 Drop)) 96 | (\xs ys -> diff ys L.isSubsequenceOf xs) 97 | where 98 | genSmall = 99 | genValidPacket defPacketOptions{poAbortMode = NoAbort} Gen.enumBounded (Range.linear 0 3) 100 | genBig = 101 | genValidPacket 102 | defPacketOptions{poAbortMode = NoAbort} 103 | Gen.enumBounded 104 | (Range.linear 9 9) 105 | 106 | -- | test to check if there are no gaps inside of packets 107 | prop_packetFifo_no_gaps :: Property 108 | prop_packetFifo_no_gaps = property $ do 109 | let maxInputSize = 50 110 | ckt = 111 | exposeClockResetEnable 112 | (packetFifoC d12 d12 Backpressure) 113 | systemClockGen 114 | resetGen 115 | enableGen 116 | gen = 117 | genPackets 118 | 1 119 | 10 120 | ( genValidPacket defPacketOptions{poAbortMode = NoAbort} Gen.enumBounded (Range.linear 0 10) 121 | ) 122 | 123 | packets :: [PacketStreamM2S 4 Int16] <- forAll gen 124 | 125 | let packetSize = 2 P.^ snatToInteger d12 126 | cfg = SimulationConfig 1 (2 * packetSize) False 127 | cktResult = simulateC ckt cfg (Just <$> packets) 128 | 129 | assert $ noGaps $ L.take (5 * maxInputSize) cktResult 130 | where 131 | noGaps :: [Maybe (PacketStreamM2S 4 Int16)] -> Bool 132 | noGaps (Just (PacketStreamM2S{_last = Nothing}) : Nothing : _) = False 133 | noGaps (_ : xs) = noGaps xs 134 | noGaps _ = True 135 | 136 | tests :: TestTree 137 | tests = 138 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 139 | $ localOption 140 | (HedgehogTestLimit (Just 500)) 141 | $(testGroupGenerator) 142 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/Packetizers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Tests.Protocols.PacketStream.Packetizers ( 4 | tests, 5 | ) where 6 | 7 | import Clash.Hedgehog.Sized.Vector (genVec) 8 | import Clash.Prelude 9 | 10 | import Hedgehog (Property) 11 | import Hedgehog.Gen qualified as Gen 12 | import Hedgehog.Range qualified as Range 13 | 14 | import Test.Tasty 15 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 16 | import Test.Tasty.Hedgehog.Extra (testProperty) 17 | import Test.Tasty.TH (testGroupGenerator) 18 | 19 | import Protocols 20 | import Protocols.Df qualified as Df 21 | import Protocols.Hedgehog 22 | import Protocols.PacketStream (packetizeFromDfC, packetizerC) 23 | import Protocols.PacketStream.Base 24 | import Protocols.PacketStream.Hedgehog 25 | 26 | {- | 27 | Test @packetizerC@ with varying data width, number of bytes in the 28 | header, input metadata, and output metadata. 29 | 30 | We consider the input metadata to be @Vec metaInBytes (BitVector 8)@ to 31 | avoid unnecessary conversions, because @packetizerC@ requires that the 32 | input metadata is convertible to this type anyway. 33 | -} 34 | packetizerPropGen :: 35 | forall 36 | (dataWidth :: Nat) 37 | (headerBytes :: Nat) 38 | (metaInBytes :: Nat) 39 | (metaOut :: Type). 40 | (KnownNat metaInBytes) => 41 | (1 <= dataWidth) => 42 | (1 <= headerBytes) => 43 | (TestType metaOut) => 44 | SNat dataWidth -> 45 | SNat headerBytes -> 46 | (Vec metaInBytes (BitVector 8) -> metaOut) -> 47 | (Vec metaInBytes (BitVector 8) -> Vec headerBytes (BitVector 8)) -> 48 | Property 49 | packetizerPropGen SNat SNat toMetaOut toHeader = 50 | idWithModelSingleDomain 51 | @System 52 | defExpectOptions 53 | ( genPackets 54 | 1 55 | 10 56 | (genValidPacket defPacketOptions (genVec Gen.enumBounded) (Range.linear 0 10)) 57 | ) 58 | (exposeClockResetEnable model) 59 | (exposeClockResetEnable ckt) 60 | where 61 | model = packetizerModel toMetaOut toHeader 62 | ckt :: 63 | (HiddenClockResetEnable System) => 64 | Circuit 65 | (PacketStream System dataWidth (Vec metaInBytes (BitVector 8))) 66 | (PacketStream System dataWidth metaOut) 67 | ckt = packetizerC toMetaOut toHeader 68 | 69 | {- | 70 | Test @packetizeFromDfC@ with varying data width, number of bytes in the 71 | header, input type, and output metadata. 72 | 73 | We consider the input type to be @Vec aBytes (BitVector 8)@ to 74 | avoid unnecessary conversions, because @packetizerC@ requires that the 75 | input type is convertible to this type anyway. 76 | -} 77 | packetizeFromDfPropGen :: 78 | forall 79 | (dataWidth :: Nat) 80 | (headerBytes :: Nat) 81 | (aBytes :: Nat) 82 | (metaOut :: Type). 83 | (KnownNat aBytes) => 84 | (1 <= dataWidth) => 85 | (1 <= headerBytes) => 86 | (TestType metaOut) => 87 | SNat dataWidth -> 88 | SNat headerBytes -> 89 | (Vec aBytes (BitVector 8) -> metaOut) -> 90 | (Vec aBytes (BitVector 8) -> Vec headerBytes (BitVector 8)) -> 91 | Property 92 | packetizeFromDfPropGen SNat SNat toMetaOut toHeader = 93 | idWithModelSingleDomain 94 | @System 95 | defExpectOptions 96 | (Gen.list (Range.linear 1 10) (genVec Gen.enumBounded)) 97 | (exposeClockResetEnable model) 98 | (exposeClockResetEnable ckt) 99 | where 100 | model = packetizeFromDfModel toMetaOut toHeader 101 | ckt :: 102 | (HiddenClockResetEnable System) => 103 | Circuit 104 | (Df.Df System (Vec aBytes (BitVector 8))) 105 | (PacketStream System dataWidth metaOut) 106 | ckt = packetizeFromDfC toMetaOut toHeader 107 | 108 | {- | 109 | Do something interesting with the input metadata to derive the output 110 | metadata for testing purposes. We just xor-reduce the input metadata. 111 | -} 112 | myToMetaOut :: Vec n (BitVector 8) -> BitVector 8 113 | myToMetaOut = foldr xor 0 114 | 115 | {- | 116 | Do something interesting with the input metadata to derive the header 117 | for testing purposes. We just xor every byte in the input metadata with 118 | an arbitrary constant and add some bytes. 119 | -} 120 | myToHeader :: 121 | forall metaInBytes headerBytes. 122 | (2 + metaInBytes ~ headerBytes) => 123 | Vec metaInBytes (BitVector 8) -> 124 | Vec headerBytes (BitVector 8) 125 | myToHeader metaIn = map (`xor` 0xAB) metaIn ++ (0x01 :> 0x02 :> Nil) 126 | 127 | -- | headerBytes % dataWidth ~ 0 128 | prop_const_packetizer_d1_d14 :: Property 129 | prop_const_packetizer_d1_d14 = 130 | packetizerPropGen d1 d14 (const ()) id 131 | 132 | prop_xor_packetizer_d1_d14 :: Property 133 | prop_xor_packetizer_d1_d14 = 134 | packetizerPropGen d1 d14 myToMetaOut myToHeader 135 | 136 | -- | dataWidth < headerBytes 137 | prop_const_packetizer_d3_d11 :: Property 138 | prop_const_packetizer_d3_d11 = 139 | packetizerPropGen d3 d11 (const ()) id 140 | 141 | prop_xor_packetizer_d3_d11 :: Property 142 | prop_xor_packetizer_d3_d11 = 143 | packetizerPropGen d3 d11 myToMetaOut myToHeader 144 | 145 | -- | dataWidth ~ header byte size 146 | prop_const_packetizer_d7_d7 :: Property 147 | prop_const_packetizer_d7_d7 = 148 | packetizerPropGen d7 d7 (const ()) id 149 | 150 | prop_xor_packetizer_d7_d7 :: Property 151 | prop_xor_packetizer_d7_d7 = 152 | packetizerPropGen d7 d7 myToMetaOut myToHeader 153 | 154 | -- | dataWidth > header byte size 155 | prop_const_packetizer_d5_d4 :: Property 156 | prop_const_packetizer_d5_d4 = 157 | packetizerPropGen d5 d4 (const ()) id 158 | 159 | prop_xor_packetizer_d5_d4 :: Property 160 | prop_xor_packetizer_d5_d4 = 161 | packetizerPropGen d5 d4 myToMetaOut myToHeader 162 | 163 | -- | headerBytes % dataWidth ~ 0 164 | prop_const_packetizeFromDf_d1_d14 :: Property 165 | prop_const_packetizeFromDf_d1_d14 = 166 | packetizeFromDfPropGen d1 d14 (const ()) id 167 | 168 | prop_xor_packetizeFromDf_d1_d14 :: Property 169 | prop_xor_packetizeFromDf_d1_d14 = 170 | packetizeFromDfPropGen d1 d14 myToMetaOut myToHeader 171 | 172 | -- | dataWidth < headerBytes 173 | prop_const_packetizeFromDf_d3_d11 :: Property 174 | prop_const_packetizeFromDf_d3_d11 = 175 | packetizeFromDfPropGen d3 d11 (const ()) id 176 | 177 | prop_xor_packetizeFromDf_d3_d11 :: Property 178 | prop_xor_packetizeFromDf_d3_d11 = 179 | packetizeFromDfPropGen d3 d11 myToMetaOut myToHeader 180 | 181 | -- | dataWidth ~ header byte size 182 | prop_const_packetizeFromDf_d7_d7 :: Property 183 | prop_const_packetizeFromDf_d7_d7 = 184 | packetizeFromDfPropGen d7 d7 (const ()) id 185 | 186 | prop_xor_packetizeFromDf_d7_d7 :: Property 187 | prop_xor_packetizeFromDf_d7_d7 = 188 | packetizeFromDfPropGen d7 d7 myToMetaOut myToHeader 189 | 190 | -- | dataWidth > header byte size 191 | prop_const_packetizeFromDf_d5_d4 :: Property 192 | prop_const_packetizeFromDf_d5_d4 = 193 | packetizeFromDfPropGen d5 d4 (const ()) id 194 | 195 | prop_xor_packetizeFromDf_d5_d4 :: Property 196 | prop_xor_packetizeFromDf_d5_d4 = 197 | packetizeFromDfPropGen d5 d4 myToMetaOut myToHeader 198 | 199 | tests :: TestTree 200 | tests = 201 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 202 | $ localOption 203 | (HedgehogTestLimit (Just 1_000)) 204 | $(testGroupGenerator) 205 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/Padding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Tests.Protocols.PacketStream.Padding ( 4 | tests, 5 | ) where 6 | 7 | import Clash.Prelude 8 | 9 | import Data.List.Extra qualified as L 10 | 11 | import Hedgehog 12 | import Hedgehog.Gen qualified as Gen 13 | import Hedgehog.Range qualified as Range 14 | 15 | import Test.Tasty 16 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 17 | import Test.Tasty.Hedgehog.Extra (testProperty) 18 | import Test.Tasty.TH (testGroupGenerator) 19 | 20 | import Protocols.Hedgehog 21 | import Protocols.PacketStream 22 | import Protocols.PacketStream.Hedgehog 23 | 24 | -- | Pure model of `stripPaddingC`. 25 | stripPaddingModel :: 26 | forall p. 27 | (KnownNat p) => 28 | [PacketStreamM2S 1 (Unsigned p)] -> 29 | [PacketStreamM2S 1 (Unsigned p)] 30 | stripPaddingModel packets = L.concatMap go (chunkByPacket packets) 31 | where 32 | go packet 33 | | packetBytes == expectedSize = packet 34 | | packetBytes > expectedSize = 35 | case padding of 36 | [] -> 37 | -- There are (packetBytes - expectedSize) bytes, so more than 0 38 | error "stripPaddingModel: absurd" 39 | (padding0 : _) -> 40 | x L.++ [padding0{_last = Just 0, _abort = any _abort padding}] 41 | | otherwise = a L.++ [b{_abort = True}] 42 | where 43 | (a, b) = case L.unsnoc packet of 44 | Nothing -> error "stripPaddingModel: list should not be empty." 45 | Just (xs, l) -> (xs, l) 46 | 47 | packetBytes = L.length packet - (if _last b == Just 0 then 1 else 0) 48 | expectedSize = fromIntegral (_meta b) 49 | 50 | (x, padding) = L.splitAt expectedSize packet 51 | 52 | {- | 53 | Test `stripPaddingC` with a given @dataWidth@ against a pure model. 54 | 55 | We make sure to test integer overflow by making the data type which holds 56 | the expected packet length extra small: @Unsigned 6@. 57 | -} 58 | stripPaddingProperty :: 59 | forall dataWidth. 60 | (1 <= dataWidth) => 61 | SNat dataWidth -> 62 | Property 63 | stripPaddingProperty SNat = 64 | idWithModelSingleDomain 65 | @System 66 | defExpectOptions 67 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 20))) 68 | (exposeClockResetEnable (upConvert . stripPaddingModel @6 . downConvert)) 69 | (exposeClockResetEnable (stripPaddingC @dataWidth id)) 70 | 71 | prop_strip_padding_d1 :: Property 72 | prop_strip_padding_d1 = stripPaddingProperty d1 73 | 74 | prop_strip_padding_d2 :: Property 75 | prop_strip_padding_d2 = stripPaddingProperty d2 76 | 77 | prop_strip_padding_d4 :: Property 78 | prop_strip_padding_d4 = stripPaddingProperty d4 79 | 80 | prop_strip_padding_d5 :: Property 81 | prop_strip_padding_d5 = stripPaddingProperty d5 82 | 83 | prop_strip_padding_d8 :: Property 84 | prop_strip_padding_d8 = stripPaddingProperty d8 85 | 86 | tests :: TestTree 87 | tests = 88 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 89 | $ localOption 90 | (HedgehogTestLimit (Just 1_000)) 91 | $(testGroupGenerator) 92 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/PacketStream/Routing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Tests.Protocols.PacketStream.Routing ( 4 | tests, 5 | ) where 6 | 7 | import Clash.Prelude 8 | 9 | import Hedgehog hiding (Parallel) 10 | import Hedgehog.Gen qualified as Gen 11 | import Hedgehog.Range qualified as Range 12 | 13 | import Test.Tasty 14 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 15 | import Test.Tasty.Hedgehog.Extra (testProperty) 16 | import Test.Tasty.TH (testGroupGenerator) 17 | 18 | import Protocols.Df qualified as Df 19 | import Protocols.Hedgehog 20 | import Protocols.PacketStream.Base 21 | import Protocols.PacketStream.Hedgehog 22 | import Protocols.PacketStream.Routing 23 | 24 | import Data.List qualified as L 25 | 26 | {- | 27 | Tests a packet arbiter for any data width and number of sources. In particular, 28 | tests that packets from all sources are sent out unmodified in the same order 29 | they were in in the source streams. 30 | -} 31 | makePropPacketArbiter :: 32 | forall sources dataWidth. 33 | (1 <= sources) => 34 | (1 <= dataWidth) => 35 | SNat sources -> 36 | SNat dataWidth -> 37 | Df.CollectMode -> 38 | Property 39 | makePropPacketArbiter SNat SNat mode = 40 | propWithModelSingleDomain 41 | @System 42 | defExpectOptions{eoSampleMax = 1000} 43 | genSources 44 | (exposeClockResetEnable L.concat) 45 | (exposeClockResetEnable (packetArbiterC mode)) 46 | (\xs ys -> partitionPackets xs === partitionPackets ys) 47 | where 48 | (minPackets, maxPackets) = case mode of 49 | -- NoSkip mode needs the same amount of packets generated for each 50 | -- source. Otherwise, starvation happens and the test won't end. 51 | Df.NoSkip -> (5, 5) 52 | _ -> (1, 10) 53 | genSources = mapM setMeta (indicesI @sources) 54 | setMeta j = do 55 | pkts <- 56 | genPackets 57 | @dataWidth 58 | minPackets 59 | maxPackets 60 | (genValidPacket defPacketOptions (pure ()) (Range.linear 0 10)) 61 | pure $ L.map (\pkt -> pkt{_meta = j}) pkts 62 | 63 | partitionPackets packets = 64 | L.sortOn getMeta 65 | $ L.groupBy (\a b -> _meta a == _meta b) 66 | <$> chunkByPacket packets 67 | 68 | getMeta ((pkt : _) : _) = _meta pkt 69 | getMeta _ = error "makePropPacketArbiter: empty partition" 70 | 71 | {- | 72 | Generic test function for the packet dispatcher, testing for all data widths, 73 | dispatch functions, and some meta types. 74 | -} 75 | makePropPacketDispatcher :: 76 | forall sinks dataWidth meta. 77 | (KnownNat sinks) => 78 | (1 <= sinks) => 79 | (1 <= dataWidth) => 80 | (TestType meta) => 81 | (Bounded meta) => 82 | (Enum meta) => 83 | (BitPack meta) => 84 | SNat dataWidth -> 85 | -- | Dispatch function 86 | Vec sinks (meta -> Bool) -> 87 | Property 88 | makePropPacketDispatcher SNat fs = 89 | idWithModelSingleDomain @System 90 | defExpectOptions{eoSampleMax = 2000, eoStopAfterEmpty = 1000} 91 | (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 6))) 92 | (exposeClockResetEnable (model 0)) 93 | (exposeClockResetEnable (packetDispatcherC fs)) 94 | where 95 | model :: 96 | Index sinks -> 97 | [PacketStreamM2S dataWidth meta] -> 98 | Vec sinks [PacketStreamM2S dataWidth meta] 99 | model _ [] = pure [] 100 | model i (y : ys) 101 | | (fs !! i) (_meta y) = 102 | let next = model 0 ys 103 | in replace i (y : (next !! i)) next 104 | | i < maxBound = model (i + 1) (y : ys) 105 | | otherwise = model 0 ys 106 | 107 | -- | Tests the @NoSkip@ packet arbiter with one source; essentially an id test. 108 | prop_packet_arbiter_noskip_id :: Property 109 | prop_packet_arbiter_noskip_id = makePropPacketArbiter d1 d2 Df.NoSkip 110 | 111 | -- | Tests the @Skip@ packet arbiter with one source; essentially an id test. 112 | prop_packet_arbiter_skip_id :: Property 113 | prop_packet_arbiter_skip_id = makePropPacketArbiter d1 d2 Df.Skip 114 | 115 | -- | Tests the @Parallel@ packet arbiter with one source; essentially an id test. 116 | prop_packet_arbiter_parallel_id :: Property 117 | prop_packet_arbiter_parallel_id = makePropPacketArbiter d1 d2 Df.Parallel 118 | 119 | -- | Tests the @NoSkip@ arbiter with five sources. 120 | prop_packet_arbiter_noskip :: Property 121 | prop_packet_arbiter_noskip = makePropPacketArbiter d5 d2 Df.NoSkip 122 | 123 | -- | Tests the @Skip@ arbiter with five sources. 124 | prop_packet_arbiter_skip :: Property 125 | prop_packet_arbiter_skip = makePropPacketArbiter d5 d2 Df.Skip 126 | 127 | -- | Tests the @Parallel@ arbiter with five sources. 128 | prop_packet_arbiter_parallel :: Property 129 | prop_packet_arbiter_parallel = makePropPacketArbiter d5 d2 Df.Parallel 130 | 131 | {- | 132 | Tests that the packet dispatcher works correctly with one sink that accepts 133 | all packets; essentially an id test. 134 | -} 135 | prop_packet_dispatcher_id :: Property 136 | prop_packet_dispatcher_id = 137 | makePropPacketDispatcher 138 | d4 139 | ((const True :: Int -> Bool) :> Nil) 140 | 141 | {- | 142 | Tests the packet dispatcher for a data width of four bytes and three 143 | overlapping but incomplete dispatch functions, effectively testing whether 144 | the circuit sends input to the first allowed output channel and drops input 145 | if there are none. 146 | -} 147 | prop_packet_dispatcher :: Property 148 | prop_packet_dispatcher = makePropPacketDispatcher d4 fs 149 | where 150 | fs :: Vec 3 (Index 4 -> Bool) 151 | fs = 152 | (>= 3) 153 | :> (>= 2) 154 | :> (>= 1) 155 | :> Nil 156 | 157 | tests :: TestTree 158 | tests = 159 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 160 | $ localOption 161 | (HedgehogTestLimit (Just 500)) 162 | $(testGroupGenerator) 163 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | -- This /must/ be enabled in order for the plugin to do its work. You might 3 | -- want to add this to 'ghc-options' in your cabal file. 4 | {-# OPTIONS_GHC -fplugin=Protocols.Plugin #-} 5 | 6 | -- For debugging purposes: 7 | -- {-# OPTIONS_GHC -fplugin-opt=Protocols.Plugin:debug #-} 8 | 9 | module Tests.Protocols.Plugin where 10 | 11 | import Clash.Prelude qualified as C 12 | 13 | import Protocols 14 | import Protocols.Df qualified as Df 15 | 16 | {- | Simply swap two streams. Note that the 'circuit' is a magic keyword the 17 | 'Protocols.Plugin' looks for in order to do its work. 18 | -} 19 | swapC :: Circuit (a, b) (b, a) 20 | swapC = circuit $ \(a, b) -> (b, a) 21 | 22 | -- | Put 'registerFwd' on both 'Df' input streams. 23 | registerBoth :: 24 | (C.NFDataX a, C.NFDataX b, C.HiddenClockResetEnable dom) => 25 | Circuit (Df dom a, Df dom b) (Df dom a, Df dom b) 26 | registerBoth = circuit $ \(a, b) -> do 27 | -- We route /a/ to into a 'registerFwd'. Note that this takes care of routing 28 | -- both the /forward/ and /backward/ parts, even though it seems that it only 29 | -- handles the /forward/ part. 30 | a' <- Df.registerFwd -< a 31 | 32 | -- Similarly, we route /b/ to a register too 33 | b' <- Df.registerFwd -< b 34 | 35 | -- The final line of a circuit-do block needs to be an "assignment". Because 36 | -- we want to simply bundle two streams, we use 'idC' as our circuit of choice. 37 | idC -< (a', b') 38 | 39 | -- | Fanout a stream and interact with some of the result streams. 40 | fanOutThenRegisterMiddle :: 41 | (C.HiddenClockResetEnable dom) => 42 | Circuit (Df dom Int) (Df dom Int, Df dom Int, Df dom Int) 43 | fanOutThenRegisterMiddle = circuit $ \a -> do 44 | -- List notation can be used to specify a Vec. In this instance, fanout will 45 | -- infer that it needs to produce a 'Vec 3 Int'. 46 | [x, y, z] <- Df.fanout -< a 47 | 48 | -- Like in 'registerBoth', we can put a register on the forward part of 'y'. 49 | y' <- Df.registerFwd -< y 50 | 51 | -- We can use any Haskell notation between the arrows, as long as it results 52 | -- in a properly typed circuit. For example, we could map the function (+5) 53 | -- over the stream 'z'. 54 | z' <- Df.map (+ 5) -< z 55 | 56 | idC -< (x, y', z') 57 | 58 | -- | Forget the /left/ part of a tuple of 'Df' streams 59 | forgetLeft :: Circuit (Df dom a, Df dom b) (Df dom b) 60 | forgetLeft = circuit $ \(a, b) -> do 61 | -- We can use an underscore to indicate that we'd like to throw away any 62 | -- data from stream 'a'. For 'Df' like protocols, a constant acknowledgement 63 | -- will be driven on the /backwards/ part of the protocol. 64 | _a <- idC -< a 65 | 66 | idC -< b 67 | 68 | -- | Forget the /left/ part of a tuple of 'Df' streams. 69 | forgetLeft2 :: Circuit (Df dom a, Df dom b) (Df dom b) 70 | forgetLeft2 = 71 | -- If we know right from the start that'd we'd like to ignore an incoming 72 | -- stream, we can simply mark it with an underscore. 73 | circuit $ \(_a, b) -> b 74 | 75 | -- | Convert a 2-vector into a 2-tuple 76 | unvec :: Circuit (C.Vec 2 a) (a, a) 77 | unvec = 78 | -- We don't always need /do/ notation 79 | circuit \[x, y] -> (x, y) 80 | -------------------------------------------------------------------------------- /clash-protocols/tests/Tests/Protocols/Vec.hs: -------------------------------------------------------------------------------- 1 | module Tests.Protocols.Vec where 2 | 3 | -- base 4 | import Prelude 5 | 6 | -- clash-prelude 7 | import Clash.Prelude (System) 8 | import Clash.Prelude qualified as C 9 | 10 | -- hedgehog 11 | import Hedgehog 12 | 13 | -- tasty 14 | import Test.Tasty 15 | import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit)) 16 | import Test.Tasty.Hedgehog.Extra (testProperty) 17 | import Test.Tasty.TH (testGroupGenerator) 18 | 19 | -- clash-protocols (me!) 20 | import Protocols 21 | import Protocols.Vec qualified as Vec 22 | 23 | import Clash.Hedgehog.Sized.Vector (genVec) 24 | import Protocols.Hedgehog 25 | 26 | -- tests 27 | import Tests.Protocols.Df (genData, genSmallInt, genVecData) 28 | 29 | prop_append :: Property 30 | prop_append = 31 | idWithModel 32 | @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int)) 33 | defExpectOptions 34 | gen 35 | model 36 | dut 37 | where 38 | gen = 39 | (,) 40 | <$> genVecData genSmallInt 41 | <*> genVecData genSmallInt 42 | dut = Vec.append 43 | model = uncurry (C.++) 44 | 45 | prop_append3 :: Property 46 | prop_append3 = 47 | idWithModel 48 | @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int), C.Vec 4 (Df System Int)) 49 | @(C.Vec 9 (Df System Int)) 50 | defExpectOptions 51 | gen 52 | model 53 | dut 54 | where 55 | gen :: Gen (C.Vec 2 [Int], C.Vec 3 [Int], C.Vec 4 [Int]) 56 | gen = 57 | (,,) 58 | <$> genVecData genSmallInt 59 | <*> genVecData genSmallInt 60 | <*> genVecData genSmallInt 61 | dut = Vec.append3 62 | model (a, b, c) = (a C.++ b) C.++ c 63 | 64 | prop_split :: Property 65 | prop_split = 66 | idWithModel 67 | @(C.Vec 5 (Df System Int)) 68 | @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int)) 69 | defExpectOptions 70 | gen 71 | model 72 | dut 73 | where 74 | gen = genVecData genSmallInt 75 | dut = Vec.split 76 | model = C.splitAtI 77 | 78 | prop_split3 :: Property 79 | prop_split3 = 80 | idWithModel 81 | @(C.Vec 9 (Df System Int)) 82 | @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int), C.Vec 4 (Df System Int)) 83 | defExpectOptions 84 | gen 85 | model 86 | dut 87 | where 88 | gen = genVecData genSmallInt 89 | dut = Vec.split3 90 | model v = (v0, v1, v2) 91 | where 92 | (v0, C.splitAtI -> (v1, v2)) = C.splitAtI v 93 | 94 | prop_zip :: Property 95 | prop_zip = 96 | idWithModel 97 | @(C.Vec 2 (Df System Int), C.Vec 2 (Df System Int)) 98 | defExpectOptions 99 | gen 100 | model 101 | dut 102 | where 103 | gen = 104 | (,) 105 | <$> genVecData genSmallInt 106 | <*> genVecData genSmallInt 107 | dut = Vec.zip 108 | model (a, b) = C.zip a b 109 | 110 | prop_zip3 :: Property 111 | prop_zip3 = 112 | idWithModel 113 | @(C.Vec 2 (Df System Int), C.Vec 2 (Df System Int), C.Vec 2 (Df System Int)) 114 | defExpectOptions 115 | gen 116 | model 117 | dut 118 | where 119 | gen = 120 | (,,) 121 | <$> genVecData genSmallInt 122 | <*> genVecData genSmallInt 123 | <*> genVecData genSmallInt 124 | dut = Vec.zip3 125 | model (a, b, c) = C.zip3 a b c 126 | 127 | prop_unzip :: Property 128 | prop_unzip = 129 | idWithModel 130 | @(C.Vec 2 (Df System Int, Df System Int)) 131 | defExpectOptions 132 | gen 133 | model 134 | dut 135 | where 136 | gen = genVec ((,) <$> genData genSmallInt <*> genData genSmallInt) 137 | dut = Vec.unzip 138 | model = C.unzip 139 | 140 | prop_unzip3 :: Property 141 | prop_unzip3 = 142 | idWithModel 143 | @(C.Vec 2 (Df System Int, Df System Int, Df System Int)) 144 | defExpectOptions 145 | gen 146 | model 147 | dut 148 | where 149 | gen = genVec ((,,) <$> genData genSmallInt <*> genData genSmallInt <*> genData genSmallInt) 150 | dut = Vec.unzip3 151 | model = C.unzip3 152 | 153 | prop_concat :: Property 154 | prop_concat = 155 | idWithModel 156 | @(C.Vec 2 (C.Vec 3 (Df System Int))) 157 | defExpectOptions 158 | gen 159 | model 160 | dut 161 | where 162 | gen = genVec (genVecData genSmallInt) 163 | dut = Vec.concat 164 | model = C.concat 165 | 166 | prop_unconcat :: Property 167 | prop_unconcat = 168 | idWithModel 169 | @(C.Vec 6 (Df System Int)) 170 | defExpectOptions 171 | gen 172 | model 173 | dut 174 | where 175 | gen = genVecData genSmallInt 176 | dut = Vec.unconcat C.d2 177 | model = C.unconcat C.d2 178 | 179 | tests :: TestTree 180 | tests = 181 | -- TODO: Move timeout option to hedgehog for better error messages. 182 | -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@?? 183 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) $ 184 | localOption 185 | (HedgehogTestLimit (Just 1000)) 186 | $(testGroupGenerator) 187 | 188 | main :: IO () 189 | main = defaultMain tests 190 | -------------------------------------------------------------------------------- /clash-protocols/tests/Util.hs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | -- base 4 | import Data.List.Extra (transpose) 5 | import Unsafe.Coerce (unsafeCoerce) 6 | 7 | -- unordered-containers 8 | 9 | import Data.HashMap.Strict (HashMap) 10 | import Data.HashMap.Strict qualified as HashMap 11 | 12 | -- hashable 13 | import Data.Hashable (Hashable) 14 | 15 | -- clash-prelude 16 | 17 | import Clash.Prelude (type (<=)) 18 | import Clash.Prelude qualified as C 19 | 20 | -- extra 21 | import Data.List.Extra qualified as Extra 22 | 23 | -- hedgehog 24 | import Hedgehog qualified as H 25 | 26 | chunksOf :: forall n. (C.KnownNat n) => [Int] -> C.Vec n [Int] 27 | chunksOf xs = vecFromList (transpose (Extra.chunksOf (C.natToNum @n) xs)) 28 | 29 | vecFromList :: forall n a. (C.KnownNat n, Monoid a) => [a] -> C.Vec n a 30 | vecFromList as = C.takeI (unsafeCoerce (as <> repeat mempty)) 31 | 32 | genVec :: (C.KnownNat n, 1 <= n) => H.Gen a -> H.Gen (C.Vec n a) 33 | genVec gen = sequence (C.repeat gen) 34 | 35 | -- | Count the number of times an element occurs in a list 36 | tally :: (Hashable a, Eq a) => [a] -> HashMap a Int 37 | tally = tallyOn id (const 1) 38 | 39 | tallyOn :: (Hashable b, Eq b) => (a -> b) -> (a -> Int) -> [a] -> HashMap b Int 40 | tallyOn f g xs = HashMap.fromListWith (+) (zip (map f xs) (map g xs)) 41 | -------------------------------------------------------------------------------- /clash-protocols/tests/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, module_sources, pkgs) 4 | import System.Environment (lookupEnv) 5 | import System.Process 6 | import Test.DocTest (doctest) 7 | import Prelude 8 | 9 | getGlobalPackageDb :: IO String 10 | getGlobalPackageDb = readProcess "ghc" ["--print-global-package-db"] "" 11 | 12 | main :: IO () 13 | main = do 14 | inNixShell <- lookupEnv "IN_NIX_SHELL" 15 | extraFlags <- 16 | case inNixShell of 17 | Nothing -> pure [] 18 | Just _ -> pure . ("-package-db=" ++) <$> getGlobalPackageDb 19 | 20 | let 21 | pluginFlags = 22 | [ "-fplugin" 23 | , "GHC.TypeLits.KnownNat.Solver" 24 | , "-fplugin" 25 | , "GHC.TypeLits.Normalise" 26 | , "-fplugin" 27 | , "GHC.TypeLits.Extra.Solver" 28 | ] 29 | 30 | doctest (flags ++ extraFlags ++ pkgs ++ pluginFlags ++ module_sources) 31 | -------------------------------------------------------------------------------- /clash-protocols/tests/unittests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent (setNumCapabilities) 4 | import System.Environment (lookupEnv, setEnv) 5 | import Test.Tasty 6 | import Text.Read (readMaybe) 7 | import Prelude 8 | 9 | import Tests.Haxioms qualified 10 | import Tests.Protocols qualified 11 | 12 | main :: IO () 13 | main = do 14 | -- Hedgehog already tets in parallel 15 | setEnv "TASTY_NUM_THREADS" "2" 16 | 17 | -- Detect "THREADS" environment variable on CI 18 | nThreads <- (readMaybe =<<) <$> lookupEnv "THREADS" 19 | case nThreads of 20 | Nothing -> pure () 21 | Just n -> do 22 | setNumCapabilities n 23 | 24 | defaultMain tests 25 | 26 | tests :: TestTree 27 | tests = 28 | testGroup 29 | "Tests" 30 | [ Tests.Haxioms.tests 31 | , Tests.Protocols.tests 32 | ] 33 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | 3 | with nixpkgs.pkgs; 4 | with gitignore; 5 | 6 | haskellPackages.callCabal2nix "clash-protocols" (gitignoreSource ./clash-protocols) {} 7 | -------------------------------------------------------------------------------- /format.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | # Help message 5 | show_help() { 6 | local script_name 7 | script_name=$(basename "$0") 8 | echo "Fourmolu formatting Script. 9 | 10 | Usage: 11 | $script_name diff Format the current git diff. 12 | $script_name full Format all source files. 13 | $script_name check Check the formatting of the source files. 14 | $script_name (-h | --help) 15 | 16 | Options: 17 | -h --help Show this screen." 18 | } 19 | 20 | # Main script logic 21 | if [[ "$#" -eq 0 || "$1" == "-h" || "$1" == "--help" ]]; then 22 | show_help 23 | exit 0 24 | fi 25 | 26 | exclude_files=( 27 | "clash-protocols-base/src/Protocols/Plugin/Cpp.hs" 28 | "dist-newstyle" 29 | ) 30 | 31 | # Make sure it doesn't matter from where this script is executed 32 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" 33 | cd $DIR 34 | 35 | if [ $1 == "diff" ] ; then 36 | src_files=$(git diff --cached --name-only --diff-filter=ACMR -- '*.hs') 37 | else 38 | src_files=$(find -type f -name "*.hs") 39 | fi 40 | 41 | src_files_str=$(printf "%s\n" "${src_files[@]}" | sed 's| |\\ |g') 42 | exclude_files_str=$(printf "%s\n" "${exclude_files[@]}" | sed 's| |\\ |g') 43 | src_files=$(echo "$src_files_str" | grep -vwE "$exclude_files_str") 44 | 45 | if [ -z "$src_files" ]; then 46 | exit 0; 47 | fi 48 | 49 | if [[ "$1" == "diff" || "$1" == "full" ]] ; then 50 | fourmolu --mode inplace $src_files 51 | elif [[ "$1" == "check" ]] ; then 52 | fourmolu --mode check $src_files 53 | else 54 | echo "Expected a single argument, \"full\", \"diff\", \"check\" or \"--help\"" >&2 55 | exit 3 56 | fi 57 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | column-limit: 90 3 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | multi: 3 | - path: "./clash-protocols-base/src" 4 | config: {cradle: {cabal: {component: "lib:clash-protocols-base"}}} 5 | - path: "./clash-protocols/src" 6 | config: {cradle: {cabal: {component: "lib:clash-protocols"}}} 7 | - path: "./clash-protocols/tests" 8 | config: {cradle: {cabal: {component: "test-suite:unittests"}}} 9 | - path: "./bin/Clash.hs" 10 | config: {cradle: {cabal: {component: "clash"}}} 11 | - path: "./bin/Clashi.hs" 12 | config: {cradle: {cabal: {component: "clashi"}}} 13 | - path: "./clash-protocols-base/Setup.hs" 14 | config: {cradle: {none: }} 15 | - path: "./clash-protocols/Setup.hs" 16 | config: {cradle: {none: }} 17 | -------------------------------------------------------------------------------- /nix/aarch64-reloc.patch: -------------------------------------------------------------------------------- 1 | From bd887b9f8a669f2269c4c420a23b64569be351b5 Mon Sep 17 00:00:00 2001 2 | From: Sylvain Henry 3 | Date: Wed, 19 Jun 2024 16:55:18 +0200 4 | Subject: [PATCH 1/3] Linker: use m32 allocator for sections when NEED_PLT 5 | (#24432) 6 | 7 | Use M32 allocator to avoid fragmentation when allocating ELF sections. 8 | We already did this when NEED_PLT was undefined. Failing to do this led 9 | to relocations impossible to fulfil (#24432). 10 | --- 11 | rts/linker/Elf.c | 26 ++++++++++++-------------- 12 | 1 file changed, 12 insertions(+), 14 deletions(-) 13 | 14 | diff --git a/rts/linker/Elf.c b/rts/linker/Elf.c 15 | index 9132d9d3973..8168103e4e5 100644 16 | --- a/rts/linker/Elf.c 17 | +++ b/rts/linker/Elf.c 18 | @@ -863,25 +863,23 @@ ocGetNames_ELF ( ObjectCode* oc ) 19 | 20 | unsigned nstubs = numberOfStubsForSection(oc, i); 21 | unsigned stub_space = STUB_SIZE * nstubs; 22 | + unsigned full_size = size+stub_space; 23 | 24 | - void * mem = mmapAnonForLinker(size+stub_space); 25 | + // use M32 allocator to avoid fragmentation and relocations impossible 26 | + // to fulfil (cf #24432) 27 | + bool executable = kind == SECTIONKIND_CODE_OR_RODATA; 28 | + m32_allocator *allocator = executable ? oc->rx_m32 : oc->rw_m32; 29 | 30 | - if( mem == MAP_FAILED ) { 31 | - barf("failed to mmap allocated memory to load section %d. " 32 | - "errno = %d", i, errno); 33 | - } 34 | + // Correctly align the section. This is particularly important for 35 | + // the alignment of .rodata.cstNN sections. 36 | + start = m32_alloc(allocator, full_size, align); 37 | + if (start == NULL) goto fail; 38 | + alloc = SECTION_M32; 39 | 40 | /* copy only the image part over; we don't want to copy data 41 | * into the stub part. 42 | */ 43 | - memcpy( mem, oc->image + offset, size ); 44 | - 45 | - alloc = SECTION_MMAP; 46 | - 47 | - mapped_offset = 0; 48 | - mapped_size = roundUpToPage(size+stub_space); 49 | - start = mem; 50 | - mapped_start = mem; 51 | + memcpy(start, oc->image + offset, size); 52 | #else 53 | if (USE_CONTIGUOUS_MMAP || RtsFlags.MiscFlags.linkerAlwaysPic) { 54 | // already mapped. 55 | @@ -918,7 +916,7 @@ ocGetNames_ELF ( ObjectCode* oc ) 56 | 57 | #if defined(NEED_PLT) 58 | oc->sections[i].info->nstubs = 0; 59 | - oc->sections[i].info->stub_offset = (uint8_t*)mem + size; 60 | + oc->sections[i].info->stub_offset = (uint8_t*)start + size; 61 | oc->sections[i].info->stub_size = stub_space; 62 | oc->sections[i].info->stubs = NULL; 63 | #else 64 | -- 65 | GitLab 66 | 67 | 68 | From 976ec5d51ab1f185b7d9ba2c15f326f2a4c8828c Mon Sep 17 00:00:00 2001 69 | From: Sylvain Henry 70 | Date: Thu, 27 Jun 2024 16:40:50 +0200 71 | Subject: [PATCH 2/3] RTS: allow M32 allocation outside of 4GB range when 72 | assuming -fPIC 73 | 74 | --- 75 | rts/linker/M32Alloc.c | 5 ++++- 76 | 1 file changed, 4 insertions(+), 1 deletion(-) 77 | 78 | diff --git a/rts/linker/M32Alloc.c b/rts/linker/M32Alloc.c 79 | index 17d3d12459c..adff1b22957 100644 80 | --- a/rts/linker/M32Alloc.c 81 | +++ b/rts/linker/M32Alloc.c 82 | @@ -156,7 +156,10 @@ static bool 83 | is_okay_address(void *p) { 84 | int8_t *here = LINKER_LOAD_BASE; 85 | ssize_t displacement = (int8_t *) p - here; 86 | - return (displacement > -0x7fffffff) && (displacement < 0x7fffffff); 87 | + // if we assume -fPIC, we don't care where we load code. 88 | + // But we still want to use the m32 allocator to avoid fragmentation (#24432) 89 | + return RtsFlags.MiscFlags.linkerAlwaysPic 90 | + || ((displacement > -0x7fffffff) && (displacement < 0x7fffffff)); 91 | } 92 | 93 | enum m32_page_type { 94 | -- 95 | GitLab 96 | 97 | 98 | From 54de3a80ebac9a782cf0cc91f3a3afcc94615817 Mon Sep 17 00:00:00 2001 99 | From: Sylvain Henry 100 | Date: Tue, 9 Jul 2024 13:00:08 +0200 101 | Subject: [PATCH 3/3] Linker: fix stub offset 102 | 103 | Remove unjustified +8 offset that leads to memory corruption (cf 104 | discussion in #24432). 105 | --- 106 | rts/linker/elf_plt.c | 3 +-- 107 | rts/linker/macho/plt.c | 3 +-- 108 | 2 files changed, 2 insertions(+), 4 deletions(-) 109 | 110 | diff --git a/rts/linker/elf_plt.c b/rts/linker/elf_plt.c 111 | index 9cd42efff23..5c6ef8ed442 100644 112 | --- a/rts/linker/elf_plt.c 113 | +++ b/rts/linker/elf_plt.c 114 | @@ -56,8 +56,7 @@ makeStub(Section * section, 115 | s->target = *addr; 116 | s->flags = flags; 117 | s->next = NULL; 118 | - s->addr = (uint8_t *)section->info->stub_offset + 8 119 | - + STUB_SIZE * section->info->nstubs; 120 | + s->addr = (uint8_t *)section->info->stub_offset + STUB_SIZE * section->info->nstubs; 121 | 122 | if((*_makeStub)(s)) 123 | return EXIT_FAILURE; 124 | diff --git a/rts/linker/macho/plt.c b/rts/linker/macho/plt.c 125 | index ed005ba447a..6eb94c29cb0 100644 126 | --- a/rts/linker/macho/plt.c 127 | +++ b/rts/linker/macho/plt.c 128 | @@ -56,8 +56,7 @@ makeStub(Section * section, 129 | s->target = *addr; 130 | s->flags = flags; 131 | s->next = NULL; 132 | - s->addr = (uint8_t *)section->info->stub_offset + 8 133 | - + STUB_SIZE * section->info->nstubs; 134 | + s->addr = (uint8_t *)section->info->stub_offset + STUB_SIZE * section->info->nstubs; 135 | 136 | if((*_makeStub)(s)) 137 | return EXIT_FAILURE; 138 | -- 139 | GitLab 140 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./sources.nix }: 2 | 3 | let 4 | haskell_compiler = "ghc965"; 5 | 6 | overlay = _: pkgs: { 7 | 8 | # Nix tooling 9 | niv = (import sources.niv {}).niv; 10 | gitignore = import sources.gitignore { inherit (pkgs) lib; }; 11 | 12 | haskell = pkgs.haskell // { 13 | compiler = pkgs.haskell.compiler // { 14 | "${haskell_compiler}" = pkgs.haskell.compiler.${haskell_compiler}.overrideAttrs (old: { 15 | # Fix for linking issues: https://gitlab.haskell.org/ghc/ghc/-/issues/24432 16 | patches = 17 | let isAarch64 = pkgs.stdenv.hostPlatform.system == "aarch64-linux"; 18 | in (old.patches or [ ]) ++ pkgs.lib.optional isAarch64 [ ./aarch64-reloc.patch ]; 19 | }); 20 | }; 21 | }; 22 | 23 | # Haskell overrides 24 | haskellPackages = pkgs.haskell.packages.${haskell_compiler}.override { 25 | overrides = self: super: { 26 | # Add overrides here 27 | circuit-notation = 28 | self.callCabal2nix "circuit-notation" sources.circuit-notation {}; 29 | doctest-parallel = 30 | self.callCabal2nix "doctest-parallel" sources.doctest-parallel {}; 31 | clash-prelude = 32 | self.callCabal2nix "clash-prelude" (sources.clash-compiler + "/clash-prelude") {}; 33 | clash-lib = 34 | self.callCabal2nix "clash-lib" (sources.clash-compiler + "/clash-lib") {}; 35 | clash-ghc = 36 | self.callCabal2nix "clash-ghc" (sources.clash-compiler + "/clash-ghc") {}; 37 | clash-prelude-hedgehog = 38 | self.callCabal2nix "clash-prelude" (sources.clash-compiler + "/clash-prelude-hedgehog") {}; 39 | tasty-hedgehog = 40 | self.callCabal2nix "tasty-hedgehog" sources.tasty-hedgehog {}; 41 | hedgehog = 42 | self.callCabal2nix "hedgehog" (sources.haskell-hedgehog + "/hedgehog") {}; 43 | clash-protocols-base = 44 | self.callCabal2nix "clash-protocols-base" (../clash-protocols-base) {}; 45 | }; 46 | }; 47 | }; 48 | 49 | in import sources.nixpkgs { overlays = [ overlay ]; } 50 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "clash-compiler": { 3 | "branch": "1.8", 4 | "description": "Haskell to VHDL/Verilog/SystemVerilog compiler", 5 | "homepage": "https://clash-lang.org/", 6 | "owner": "clash-lang", 7 | "repo": "clash-compiler", 8 | "rev": "3f5dc67c0e526e43a4dd88eb3902e39ed512c166", 9 | "sha256": "022rwif8xkaabw0j3arhyj0hswmh3vq2nx1bbz8rbkp05jm4psgg", 10 | "type": "tarball", 11 | "url": "https://github.com/clash-lang/clash-compiler/archive/3f5dc67c0e526e43a4dd88eb3902e39ed512c166.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz", 13 | "version": "1.8.1" 14 | }, 15 | "doctest-parallel": { 16 | "branch": "main", 17 | "description": "Test interactive Haskell examples", 18 | "homepage": null, 19 | "owner": "martijnbastiaan", 20 | "repo": "doctest-parallel", 21 | "rev": "d73df0a2fd58b0b6aba438eb40aa56d30724e42a", 22 | "sha256": "1k88bkwz2crvb6dafcf6y5y6wm0m2qvds57f3b0rx4id7la4qv89", 23 | "type": "tarball", 24 | "url": "https://github.com/martijnbastiaan/doctest-parallel/archive/d73df0a2fd58b0b6aba438eb40aa56d30724e42a.tar.gz", 25 | "url_template": "https://github.com///archive/.tar.gz", 26 | "version": "0.3.1" 27 | }, 28 | "gitignore": { 29 | "branch": "master", 30 | "description": "Nix function for filtering local git sources", 31 | "homepage": "", 32 | "owner": "hercules-ci", 33 | "repo": "gitignore", 34 | "rev": "bff2832ec341cf30acb3a4d3e2e7f1f7b590116a", 35 | "sha256": "0va0janxvmilm67nbl81gdbpppal4aprxzb25gp9pqvf76ahxsci", 36 | "type": "tarball", 37 | "url": "https://github.com/hercules-ci/gitignore/archive/bff2832ec341cf30acb3a4d3e2e7f1f7b590116a.tar.gz", 38 | "url_template": "https://github.com///archive/.tar.gz" 39 | }, 40 | "haskell-hedgehog": { 41 | "branch": "master", 42 | "description": "Release with confidence, state-of-the-art property testing for Haskell.", 43 | "homepage": "", 44 | "owner": "hedgehogqa", 45 | "repo": "haskell-hedgehog", 46 | "rev": "52c35cabe24de2a1c03e72dde9d04b64f81d1f44", 47 | "sha256": "1f9znljkmrdd4nlfmjfi8kx0fgcysp328rz27099n7bygchpgjr6", 48 | "type": "tarball", 49 | "url": "https://github.com/hedgehogqa/haskell-hedgehog/archive/52c35cabe24de2a1c03e72dde9d04b64f81d1f44.tar.gz", 50 | "url_template": "https://github.com///archive/.tar.gz", 51 | "version": "1.4" 52 | }, 53 | "circuit-notation": { 54 | "branch": "master", 55 | "description": "A plugin for circuit notation", 56 | "homepage": null, 57 | "owner": "cchalmers", 58 | "repo": "circuit-notation", 59 | "rev": "19b386c4aa3ff690758ae089c7754303f3500cc9", 60 | "sha256": "0qz2w6akxj51kq50rbl88bnjyxzd2798a9sn9jj1z2kak7a6kqbg", 61 | "type": "tarball", 62 | "url": "https://github.com/cchalmers/circuit-notation/archive/19b386c4aa3ff690758ae089c7754303f3500cc9.tar.gz", 63 | "url_template": "https://github.com///archive/.tar.gz" 64 | }, 65 | "niv": { 66 | "branch": "master", 67 | "description": "Easy dependency management for Nix projects", 68 | "homepage": "https://github.com/nmattia/niv", 69 | "owner": "nmattia", 70 | "repo": "niv", 71 | "rev": "723f0eeb969a730db3c30f977c2b66b9dce9fe4a", 72 | "sha256": "0016l7230gd2kdh0g2w573r9a2krqb7x4ifcjhhsn4h1bwap7qr0", 73 | "type": "tarball", 74 | "url": "https://github.com/nmattia/niv/archive/723f0eeb969a730db3c30f977c2b66b9dce9fe4a.tar.gz", 75 | "url_template": "https://github.com///archive/.tar.gz" 76 | }, 77 | "nixpkgs": { 78 | "branch": "nixpkgs-unstable", 79 | "description": "Nix Packages collection", 80 | "homepage": "", 81 | "owner": "NixOS", 82 | "repo": "nixpkgs", 83 | "rev": "e2dd4e18cc1c7314e24154331bae07df76eb582f", 84 | "sha256": "19zbxf7rb787jvyrfhl4z9sn3aisd6xvx6ikybbi75ym9sy39jds", 85 | "type": "tarball", 86 | "url": "https://github.com/NixOS/nixpkgs/archive/e2dd4e18cc1c7314e24154331bae07df76eb582f.tar.gz", 87 | "url_template": "https://github.com///archive/.tar.gz" 88 | }, 89 | "tasty-hedgehog": { 90 | "branch": "master", 91 | "description": "Tasty integration for the Hedgehog property testing library", 92 | "homepage": "", 93 | "owner": "qfpl", 94 | "repo": "tasty-hedgehog", 95 | "rev": "ed07ecef3f6a01572b577b450ba6d58108173125", 96 | "sha256": "1b8y5ibg1ihgf44nyym4g45lwmabymfcjb2nigv93s2fmng9zp6r", 97 | "type": "tarball", 98 | "url": "https://github.com/qfpl/tasty-hedgehog/archive/ed07ecef3f6a01572b577b450ba6d58108173125.tar.gz", 99 | "url_template": "https://github.com///archive/.tar.gz", 100 | "version": "1.4.0.2" 101 | } 102 | } 103 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | spec.ref or ( 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!" 34 | ); 35 | submodules = spec.submodules or false; 36 | submoduleArg = 37 | let 38 | nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0; 39 | emptyArgWithWarning = 40 | if submodules 41 | then 42 | builtins.trace 43 | ( 44 | "The niv input \"${name}\" uses submodules " 45 | + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " 46 | + "does not support them" 47 | ) 48 | { } 49 | else { }; 50 | in 51 | if nixSupportsSubmodules 52 | then { inherit submodules; } 53 | else emptyArgWithWarning; 54 | in 55 | builtins.fetchGit 56 | ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); 57 | 58 | fetch_local = spec: spec.path; 59 | 60 | fetch_builtin-tarball = name: throw 61 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 62 | $ niv modify ${name} -a type=tarball -a builtin=true''; 63 | 64 | fetch_builtin-url = name: throw 65 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 66 | $ niv modify ${name} -a type=file -a builtin=true''; 67 | 68 | # 69 | # Various helpers 70 | # 71 | 72 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 73 | sanitizeName = name: 74 | ( 75 | concatMapStrings (s: if builtins.isList s then "-" else s) 76 | ( 77 | builtins.split "[^[:alnum:]+._?=-]+" 78 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 79 | ) 80 | ); 81 | 82 | # The set of packages used when specs are fetched using non-builtins. 83 | mkPkgs = sources: system: 84 | let 85 | sourcesNixpkgs = 86 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 87 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 88 | hasThisAsNixpkgsPath = == ./.; 89 | in 90 | if builtins.hasAttr "nixpkgs" sources 91 | then sourcesNixpkgs 92 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 93 | import { } 94 | else 95 | abort 96 | '' 97 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 98 | add a package called "nixpkgs" to your sources.json. 99 | ''; 100 | 101 | # The actual fetching function. 102 | fetch = pkgs: name: spec: 103 | 104 | if ! builtins.hasAttr "type" spec then 105 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 106 | else if spec.type == "file" then fetch_file pkgs name spec 107 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 108 | else if spec.type == "git" then fetch_git name spec 109 | else if spec.type == "local" then fetch_local spec 110 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 111 | else if spec.type == "builtin-url" then fetch_builtin-url name 112 | else 113 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 114 | 115 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 116 | # the path directly as opposed to the fetched source. 117 | replace = name: drv: 118 | let 119 | saneName = stringAsChars (c: if (builtins.match "[a-zA-Z0-9]" c) == null then "_" else c) name; 120 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 121 | in 122 | if ersatz == "" then drv else 123 | # this turns the string into an actual Nix path (for both absolute and 124 | # relative paths) 125 | if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; 126 | 127 | # Ports of functions for older nix versions 128 | 129 | # a Nix version of mapAttrs if the built-in doesn't exist 130 | mapAttrs = builtins.mapAttrs or ( 131 | f: set: with builtins; 132 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 133 | ); 134 | 135 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 136 | range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1); 137 | 138 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 139 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 140 | 141 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 142 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 143 | concatMapStrings = f: list: concatStrings (map f list); 144 | concatStrings = builtins.concatStringsSep ""; 145 | 146 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 147 | optionalAttrs = cond: as: if cond then as else { }; 148 | 149 | # fetchTarball version that is compatible between all the versions of Nix 150 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 151 | let 152 | inherit (builtins) lessThan nixVersion fetchTarball; 153 | in 154 | if lessThan nixVersion "1.12" then 155 | fetchTarball ({ inherit url; } // (optionalAttrs (name != null) { inherit name; })) 156 | else 157 | fetchTarball attrs; 158 | 159 | # fetchurl version that is compatible between all the versions of Nix 160 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 161 | let 162 | inherit (builtins) lessThan nixVersion fetchurl; 163 | in 164 | if lessThan nixVersion "1.12" then 165 | fetchurl ({ inherit url; } // (optionalAttrs (name != null) { inherit name; })) 166 | else 167 | fetchurl attrs; 168 | 169 | # Create the final "sources" from the config 170 | mkSources = config: 171 | mapAttrs 172 | ( 173 | name: spec: 174 | if builtins.hasAttr "outPath" spec 175 | then 176 | abort 177 | "The values in sources.json should not have an 'outPath' attribute" 178 | else 179 | spec // { outPath = replace name (fetch config.pkgs name spec); } 180 | ) 181 | config.sources; 182 | 183 | # The "config" used by the fetchers 184 | mkConfig = 185 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 186 | , sources ? if sourcesFile == null then { } else builtins.fromJSON (builtins.readFile sourcesFile) 187 | , system ? builtins.currentSystem 188 | , pkgs ? mkPkgs sources system 189 | }: rec { 190 | # The sources, i.e. the attribute set of spec name to spec 191 | inherit sources; 192 | 193 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 194 | inherit pkgs; 195 | }; 196 | 197 | in 198 | mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); } 199 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import ./nix/nixpkgs.nix { }; 3 | in 4 | pkgs.haskellPackages.callPackage ./default.nix { } 5 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | inherit (pkgs) haskellPackages; 5 | 6 | project = import ./release.nix; 7 | in 8 | 9 | pkgs.stdenv.mkDerivation { 10 | name = "shell"; 11 | buildInputs = project.env.nativeBuildInputs ++ [ 12 | haskellPackages.cabal-install 13 | haskellPackages.fourmolu 14 | haskellPackages.haskell-language-server 15 | ]; 16 | LC_ALL = "C.UTF-8"; 17 | } 18 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.6 # ghc-9.8.4 2 | 3 | packages: 4 | - clash-protocols-base 5 | - clash-protocols 6 | 7 | extra-deps: 8 | - git: https://github.com/cchalmers/circuit-notation.git 9 | commit: 564769c52aa05b90f81bbc898b7af7087d96613d 10 | - clash-prelude-1.8.2 11 | - clash-prelude-hedgehog-1.8.2 12 | - hedgehog-1.4@sha256:9860ab34ab3951d9515c71b777d8c9c47610aae7339933e17d26ad9a4afa5618,4754 13 | - tasty-1.4.3@sha256:5b53fded93109f6704b599c3498eb73c5b0ed1a975f1912dd98b4b19c61f8bc9,2653 14 | --------------------------------------------------------------------------------