├── .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 │ │ ├── List │ │ │ └── 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 ├── flake.lock ├── flake.nix ├── format.sh ├── fourmolu.yaml ├── hie.yaml ├── nix └── aarch64-reloc.patch └── 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 | id: setup-haskell 26 | with: 27 | ghc-version: '9.8.4' 28 | cabal-version: '3.14.1.1' 29 | enable-stack: true 30 | stack-version: 'latest' 31 | 32 | # Ask Stack to use system GHC instead of installing its own copy 33 | - name: Use system GHC 34 | run: | 35 | stack config set system-ghc --global true 36 | 37 | - name: Cache dependencies 38 | uses: actions/cache@v4 39 | id: cache 40 | with: 41 | path: ${{ steps.setup-haskell.outputs.stack-root }} 42 | key: stack-${{ runner.os }}-${{ steps.setup-haskell.outputs.stack-version }}-${{ hashFiles('stack.yaml', '**/*.cabal') }} 43 | 44 | - name: Install dependencies 45 | run: stack build --test --only-dependencies 46 | 47 | - name: Test with Stack 48 | run: | 49 | .ci/test_stack.sh 50 | 51 | cabal: 52 | name: Cabal tests - ghc ${{ matrix.ghc }} / clash ${{ matrix.clash }} / doc ${{ matrix.check_haddock }} 53 | runs-on: ${{ matrix.os }} 54 | strategy: 55 | fail-fast: false 56 | matrix: 57 | os: [ubuntu-latest] 58 | clash: 59 | - "1.8.2" 60 | cabal: 61 | - "3.14.1.1" 62 | ghc: 63 | - "9.2.8" 64 | - "9.4.8" 65 | - "9.8.4" 66 | - "9.10.1" 67 | include: 68 | - check_haddock: "False" 69 | - ghc: "9.6.6" 70 | check_haddock: "True" 71 | os: "ubuntu-latest" 72 | clash: "1.8.2" 73 | cabal: "3.14.1.1" 74 | 75 | env: 76 | check_haddock: ${{ matrix.check_haddock }} 77 | clash_version: ${{ matrix.clash }} 78 | 79 | steps: 80 | - name: Checkout 81 | uses: actions/checkout@v4 82 | 83 | - name: Setup Haskell 84 | uses: haskell-actions/setup@v2 85 | id: setup-haskell 86 | with: 87 | ghc-version: ${{ matrix.ghc }} 88 | cabal-version: ${{ matrix.cabal }} 89 | 90 | - name: Use CI specific settings 91 | run: | 92 | .ci/apply_settings.sh 93 | 94 | - name: Setup CI 95 | run: | 96 | cabal v2-freeze 97 | mv cabal.project.freeze frozen 98 | 99 | - name: Restore cached dependencies 100 | uses: actions/cache@v4 101 | id: cache 102 | with: 103 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 104 | key: ${{ runner.os }}-ghc-${{ matrix.ghc }}-${{ steps.setup-haskell.outputs.cabal-version }}-${{ hashFiles('frozen') }} 105 | 106 | - name: Install dependencies 107 | run: cabal v2-build all --enable-tests --only-dependencies 108 | 109 | - name: Build 110 | run: | 111 | cabal v2-build all --enable-tests 112 | 113 | - name: Test 114 | run: | 115 | .ci/test_cabal.sh 116 | 117 | - name: Documentation 118 | if: ${{ matrix.check_haddock == 'True' }} 119 | run: | 120 | .ci/build_docs.sh 121 | 122 | fourmolu: 123 | runs-on: ubuntu-latest 124 | steps: 125 | # Note that you must checkout your code before running haskell-actions/run-fourmolu 126 | - uses: actions/checkout@v3 127 | - uses: haskell-actions/run-fourmolu@v9 128 | with: 129 | version: "0.16.2.0" 130 | pattern: | 131 | **/*.hs 132 | !clash-protocols-base/src/Protocols/Plugin/Cpp.hs 133 | 134 | linting: 135 | name: Source code linting 136 | runs-on: ubuntu-latest 137 | steps: 138 | - name: Checkout 139 | uses: actions/checkout@v4 140 | 141 | - name: Whitespace 142 | run: | 143 | .ci/test_whitespace.sh 144 | 145 | # Mandatory check on GitHub 146 | all: 147 | name: All jobs finished 148 | if: always() 149 | needs: [ 150 | cabal, 151 | fourmolu, 152 | linting, 153 | stack, 154 | ] 155 | runs-on: ubuntu-22.04 156 | steps: 157 | - name: Checkout 158 | uses: actions/checkout@v4 159 | 160 | - name: Check dependencies for failures 161 | run: | 162 | # Test all dependencies for success/failure 163 | set -x 164 | success="${{ contains(needs.*.result, 'success') }}" 165 | fail="${{ contains(needs.*.result, 'failure') }}" 166 | set +x 167 | 168 | # Test whether success/fail variables contain sane values 169 | if [[ "${success}" != "true" && "${success}" != "false" ]]; then exit 1; fi 170 | if [[ "${fail}" != "true" && "${fail}" != "false" ]]; then exit 1; fi 171 | 172 | # We want to fail if one or more dependencies fail. For safety, we introduce 173 | # a second check: if no dependencies succeeded something weird is going on. 174 | if [[ "${fail}" == "true" || "${success}" == "false" ]]; then 175 | echo "One or more dependency failed, or no dependency succeeded." 176 | exit 1 177 | fi 178 | 179 | - name: Install dependencies 180 | run: | 181 | sudo apt-get update 182 | sudo apt-get -y install python3-yaml 183 | 184 | - name: Check that the 'all' job depends on all other jobs 185 | run: | 186 | .github/scripts/all_check.py 187 | -------------------------------------------------------------------------------- /.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 | -- Clash needs access to the source code in compiled modules 45 | -fexpose-all-unfoldings 46 | 47 | -- Worker wrappers introduce unstable names for functions that might have 48 | -- blackboxes attached for them. You can disable this, but be sure to add 49 | -- a no-specialize pragma to every function with a blackbox. 50 | -fno-worker-wrapper 51 | 52 | default-language: GHC2021 53 | build-depends: 54 | base >= 4.16.1.0, 55 | Cabal, 56 | 57 | clash-prelude >= 1.8.1 && < 1.10, 58 | 59 | library 60 | import: common-options 61 | hs-source-dirs: src 62 | 63 | if flag(large-tuples) 64 | CPP-Options: -DLARGE_TUPLES 65 | 66 | build-depends: 67 | , circuit-notation 68 | , deepseq 69 | , extra 70 | , ghc >= 8.7 && < 9.11 71 | , hashable 72 | , tagged 73 | , template-haskell 74 | 75 | exposed-modules: 76 | Protocols.Plugin 77 | Protocols.Plugin.Cpp 78 | Protocols.Plugin.Internal 79 | Protocols.Plugin.TaggedBundle 80 | Protocols.Plugin.TaggedBundle.TH 81 | Protocols.Plugin.TH 82 | Protocols.Plugin.Units 83 | Protocols.Plugin.Units.TH 84 | 85 | other-modules: 86 | Protocols.Plugin.Types 87 | 88 | default-language: GHC2021 89 | -------------------------------------------------------------------------------- /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 | DerivingStrategies 38 | LambdaCase 39 | NoStarIsType 40 | OverloadedRecordDot 41 | PackageImports 42 | StandaloneDeriving 43 | TupleSections 44 | TypeApplications 45 | TypeFamilies 46 | TypeOperators 47 | ViewPatterns 48 | 49 | -- TemplateHaskell is used to support convenience functions such as 50 | -- 'listToVecTH' and 'bLit'. 51 | TemplateHaskell 52 | QuasiQuotes 53 | 54 | -- Prelude isn't imported by default as Clash offers Clash.Prelude 55 | -- NoImplicitPrelude 56 | ghc-options: 57 | -Wall -Wcompat 58 | 59 | -- Plugins to support type-level constraint solving on naturals 60 | -fplugin GHC.TypeLits.Extra.Solver 61 | -fplugin GHC.TypeLits.Normalise 62 | -fplugin GHC.TypeLits.KnownNat.Solver 63 | 64 | -- Clash needs access to the source code in compiled modules 65 | -fexpose-all-unfoldings 66 | 67 | -- Worker wrappers introduce unstable names for functions that might have 68 | -- blackboxes attached for them. You can disable this, but be sure to add 69 | -- a no-specialize pragma to every function with a blackbox. 70 | -fno-worker-wrapper 71 | 72 | default-language: GHC2021 73 | build-depends: 74 | base >= 4.16.1.0, 75 | Cabal, 76 | 77 | clash-prelude >= 1.8.1 && < 1.10, 78 | ghc-typelits-natnormalise, 79 | ghc-typelits-extra, 80 | ghc-typelits-knownnat 81 | 82 | custom-setup 83 | setup-depends: 84 | base >= 4.16 && <5, 85 | Cabal >= 2.4, 86 | cabal-doctest >= 1.0.1 && <1.1 87 | 88 | library 89 | import: common-options 90 | hs-source-dirs: src 91 | 92 | if flag(large-tuples) 93 | CPP-Options: -DLARGE_TUPLES 94 | 95 | build-depends: 96 | , clash-protocols-base 97 | , circuit-notation 98 | , clash-prelude-hedgehog 99 | , constraints 100 | , data-default ^>= 0.7.1.1 101 | , deepseq 102 | , extra 103 | , hashable 104 | , hedgehog >= 1.0.2 105 | , lifted-async 106 | , mtl 107 | , pretty-show 108 | , strict-tuple 109 | , tagged 110 | , template-haskell 111 | 112 | -- To be removed; we need 'Test.Tasty.Hedgehog.Extra' to fix upstream issues 113 | , tasty >= 1.2 && < 1.6 114 | , tasty-hedgehog >= 1.2 115 | , string-interpolate 116 | 117 | exposed-modules: 118 | Protocols 119 | Protocols.Avalon.MemMap 120 | Protocols.Avalon.Stream 121 | Protocols.Axi4.Common 122 | Protocols.Axi4.ReadAddress 123 | Protocols.Axi4.ReadData 124 | Protocols.Axi4.Stream 125 | Protocols.Axi4.WriteAddress 126 | Protocols.Axi4.WriteData 127 | Protocols.Axi4.WriteResponse 128 | Protocols.PacketStream 129 | Protocols.PacketStream.Base 130 | Protocols.PacketStream.AsyncFifo 131 | Protocols.PacketStream.Converters 132 | Protocols.PacketStream.Depacketizers 133 | Protocols.PacketStream.Hedgehog 134 | Protocols.PacketStream.PacketFifo 135 | Protocols.PacketStream.Packetizers 136 | Protocols.PacketStream.Padding 137 | Protocols.PacketStream.Routing 138 | Protocols.Df 139 | Protocols.DfConv 140 | Protocols.Hedgehog 141 | Protocols.Hedgehog.Internal 142 | Protocols.Idle 143 | Protocols.Internal 144 | Protocols.Internal.TH 145 | Protocols.Vec 146 | Protocols.Wishbone 147 | Protocols.Wishbone.Standard 148 | Protocols.Wishbone.Standard.Hedgehog 149 | 150 | Data.List.Extra 151 | 152 | -- 'testProperty' is broken upstream, it reports wrong test names 153 | -- TODO: test / upstream ^ 154 | Test.Tasty.Hedgehog.Extra 155 | 156 | reexported-modules: 157 | Protocols.Plugin 158 | 159 | autogen-modules: Paths_clash_protocols 160 | 161 | other-modules: 162 | Data.Constraint.Nat.Extra 163 | Data.Maybe.Extra 164 | Clash.Sized.Vector.Extra 165 | Paths_clash_protocols 166 | Protocols.Hedgehog.Types 167 | Protocols.Internal.Types 168 | 169 | default-language: GHC2021 170 | 171 | test-suite unittests 172 | import: common-options 173 | hs-source-dirs: tests 174 | type: exitcode-stdio-1.0 175 | ghc-options: -threaded -with-rtsopts=-N 176 | main-is: unittests.hs 177 | other-modules: 178 | Tests.Haxioms 179 | Tests.Protocols 180 | Tests.Protocols.Df 181 | Tests.Protocols.DfConv 182 | Tests.Protocols.Avalon 183 | Tests.Protocols.Axi4 184 | Tests.Protocols.Plugin 185 | Tests.Protocols.Vec 186 | Tests.Protocols.Wishbone 187 | Tests.Protocols.PacketStream 188 | Tests.Protocols.PacketStream.AsyncFifo 189 | Tests.Protocols.PacketStream.Base 190 | Tests.Protocols.PacketStream.Converters 191 | Tests.Protocols.PacketStream.Depacketizers 192 | Tests.Protocols.PacketStream.Packetizers 193 | Tests.Protocols.PacketStream.PacketFifo 194 | Tests.Protocols.PacketStream.Padding 195 | Tests.Protocols.PacketStream.Routing 196 | 197 | Util 198 | 199 | build-depends: 200 | string-interpolate, 201 | clash-protocols-base, 202 | clash-protocols, 203 | clash-prelude-hedgehog, 204 | unordered-containers, 205 | deepseq, 206 | extra, 207 | hashable, 208 | hedgehog, 209 | strict-tuple, 210 | tasty >= 1.2 && < 1.6, 211 | tasty-hedgehog >= 1.2, 212 | tasty-th, 213 | tasty-hunit 214 | 215 | test-suite doctests 216 | import: common-options 217 | type: exitcode-stdio-1.0 218 | default-language: GHC2021 219 | main-is: doctests.hs 220 | hs-source-dirs: tests 221 | 222 | build-depends: 223 | base, 224 | clash-protocols-base, 225 | clash-protocols, 226 | process, 227 | doctest 228 | -------------------------------------------------------------------------------- /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/List/Extra.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Utility functions that operate on lists, but are not part of `Data.List`. 3 | -} 4 | module Data.List.Extra where 5 | 6 | import "base" Data.List qualified as L 7 | 8 | {- | 9 | Takes elements from a list while the predicate holds, considers up to @window@ elements 10 | since the last element that satisfied the predicate. 11 | 12 | >>> takeWhileAnyInWindow 3 Prelude.odd [1, 2, 3, 6, 8, 10, 12] 13 | [1,2,3] 14 | -} 15 | takeWhileAnyInWindow :: 16 | -- | Number of elements to consider since the last element that satisfied the predicate. 17 | Int -> 18 | -- | Function to test each element. 19 | (a -> Bool) -> 20 | -- | Input list 21 | [a] -> 22 | -- | List of elements that satisfied the predicate. Ends at an element that 23 | -- satisfies the predicate. 24 | [a] 25 | takeWhileAnyInWindow wdw predicate = go wdw [] 26 | where 27 | go 0 _ _ = [] 28 | go cnt acc (x : xs) 29 | | predicate x = L.reverse (x : acc) <> go wdw [] xs 30 | | otherwise = go (pred cnt) (x : acc) xs 31 | go _ _ _ = [] 32 | -------------------------------------------------------------------------------- /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 | applyC, 34 | prod2C, 35 | 36 | -- * Simulation 37 | Simulate ( 38 | SimulateFwdType, 39 | SimulateBwdType, 40 | SimulateChannels, 41 | sigToSimFwd, 42 | sigToSimBwd, 43 | simToSigFwd, 44 | simToSigBwd, 45 | stallC 46 | ), 47 | Drivable ( 48 | ExpectType, 49 | toSimulateType, 50 | fromSimulateType, 51 | driveC, 52 | sampleC 53 | ), 54 | SimulationConfig (..), 55 | StallAck (..), 56 | simulateC, 57 | simulateCS, 58 | def, 59 | 60 | -- * Circuit notation plugin 61 | circuit, 62 | (-<), 63 | Units (..), 64 | TaggedBundle (..), 65 | ) where 66 | 67 | import Data.Default (def) 68 | import Protocols.Df (Df) 69 | import Protocols.Internal 70 | -------------------------------------------------------------------------------- /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, Eq, Generic) 111 | deriving anyclass (C.ShowX, 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.ShowX (ResponseType (RKeepResponse conf)) 122 | , Eq (ResponseType (RKeepResponse conf)) 123 | , C.NFDataX (ResponseType (RKeepResponse conf)) 124 | , C.BitPack (ResponseType (RKeepResponse conf)) 125 | ) 126 | 127 | deriving instance 128 | ( KnownAxi4ReadDataConfig conf 129 | , Show userType 130 | , Show dataType 131 | ) => 132 | Show (S2M_ReadData conf userType dataType) 133 | 134 | deriving instance 135 | ( KnownAxi4ReadDataConfig conf 136 | , C.ShowX userType 137 | , C.ShowX dataType 138 | ) => 139 | C.ShowX (S2M_ReadData conf userType dataType) 140 | 141 | deriving instance 142 | ( KnownAxi4ReadDataConfig conf 143 | , Eq userType 144 | , Eq dataType 145 | ) => 146 | Eq (S2M_ReadData conf userType dataType) 147 | 148 | deriving instance 149 | ( KnownAxi4ReadDataConfig conf 150 | , C.NFDataX userType 151 | , C.NFDataX dataType 152 | ) => 153 | C.NFDataX (S2M_ReadData conf userType dataType) 154 | 155 | instance IdleCircuit (Axi4ReadData dom conf userType dataType) where 156 | idleFwd _ = C.pure S2M_NoReadData 157 | idleBwd _ = C.pure $ M2S_ReadData False 158 | 159 | {- | Force a /nack/ on the backward channel and /no data/ on the forward 160 | channel if reset is asserted. 161 | -} 162 | forceResetSanity :: 163 | forall dom conf userType dataType. 164 | (C.HiddenClockResetEnable dom) => 165 | Circuit 166 | (Axi4ReadData dom conf userType dataType) 167 | (Axi4ReadData dom conf userType dataType) 168 | forceResetSanity = forceResetSanityGeneric 169 | -------------------------------------------------------------------------------- /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 | {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} 4 | 5 | {- | 6 | Defines WriteData channel of full AXI4 protocol with port names corresponding 7 | to the AXI4 specification. 8 | -} 9 | module Protocols.Axi4.WriteData ( 10 | M2S_WriteData (..), 11 | S2M_WriteData (..), 12 | Axi4WriteData, 13 | 14 | -- * configuration 15 | Axi4WriteDataConfig (..), 16 | KnownAxi4WriteDataConfig, 17 | WKeepStrobe, 18 | WNBytes, 19 | ) where 20 | 21 | -- base 22 | import Data.Coerce (coerce) 23 | import Data.Kind (Type) 24 | import GHC.Generics (Generic) 25 | import Prelude hiding ( 26 | const, 27 | either, 28 | filter, 29 | fst, 30 | map, 31 | pure, 32 | snd, 33 | zip, 34 | zipWith, 35 | (!!), 36 | ) 37 | 38 | -- clash-prelude 39 | import Clash.Prelude qualified as C 40 | 41 | -- me 42 | import Protocols.Axi4.Common 43 | import Protocols.Idle 44 | import Protocols.Internal 45 | 46 | -- | Configuration options for 'Axi4WriteData'. 47 | data Axi4WriteDataConfig = Axi4WriteDataConfig 48 | { _wKeepStrobe :: Bool 49 | , _wNBytes :: C.Nat 50 | } 51 | 52 | {- | Grab '_wKeepStrobe' from 'Axi4WriteDataConfig' at the type level. 53 | This boolean value determines whether to keep strobe values in the '_wdata' field 54 | in 'M2S_WriteData'. 55 | -} 56 | type family WKeepStrobe (conf :: Axi4WriteDataConfig) where 57 | WKeepStrobe ('Axi4WriteDataConfig a _) = a 58 | 59 | {- | Grab '_wNBytes' from 'Axi4WriteDataConfig' at the type level. 60 | This nat value determines the size of the '_wdata' field 61 | in 'M2S_WriteData'. 62 | -} 63 | type family WNBytes (conf :: Axi4WriteDataConfig) where 64 | WNBytes ('Axi4WriteDataConfig _ a) = a 65 | 66 | -- | AXI4 Write Data channel protocol 67 | data 68 | Axi4WriteData 69 | (dom :: C.Domain) 70 | (conf :: Axi4WriteDataConfig) 71 | (userType :: Type) 72 | 73 | instance Protocol (Axi4WriteData dom conf userType) where 74 | type 75 | Fwd (Axi4WriteData dom conf userType) = 76 | C.Signal dom (M2S_WriteData conf userType) 77 | type 78 | Bwd (Axi4WriteData dom conf userType) = 79 | C.Signal dom S2M_WriteData 80 | 81 | instance Backpressure (Axi4WriteData dom conf userType) where 82 | boolsToBwd _ = C.fromList_lazy . coerce 83 | 84 | {- | See Table A2-3 "Write data channel signals". If strobing is kept, the data 85 | will be a vector of 'Maybe' bytes. If strobing is not kept, data will be a 86 | 'C.BitVector'. 87 | -} 88 | data 89 | M2S_WriteData 90 | (conf :: Axi4WriteDataConfig) 91 | (userType :: Type) 92 | = M2S_NoWriteData 93 | | M2S_WriteData 94 | { _wdata :: StrictStrobeType (WNBytes conf) (WKeepStrobe conf) 95 | -- ^ Write data 96 | , _wlast :: Bool 97 | -- ^ Write last 98 | , _wuser :: userType 99 | -- ^ User data 100 | } 101 | deriving (Generic) 102 | 103 | -- | See Table A2-3 "Write data channel signals" 104 | newtype S2M_WriteData = S2M_WriteData {_wready :: Bool} 105 | deriving stock (Show, Generic) 106 | deriving anyclass (C.NFDataX, C.BitPack) 107 | 108 | {- | Shorthand for a "well-behaved" write data config, 109 | so that we don't need to write out a bunch of type constraints later. 110 | Holds for every configuration; don't worry about implementing this class. 111 | -} 112 | type KnownAxi4WriteDataConfig conf = 113 | ( KeepStrobeClass (WKeepStrobe conf) 114 | , C.KnownNat (WNBytes conf) 115 | , Eq (StrobeDataType (WKeepStrobe conf)) 116 | , Show (StrobeDataType (WKeepStrobe conf)) 117 | , C.ShowX (StrobeDataType (WKeepStrobe conf)) 118 | , C.NFDataX (StrobeDataType (WKeepStrobe conf)) 119 | , C.BitPack (StrobeDataType (WKeepStrobe conf)) 120 | ) 121 | 122 | deriving instance 123 | ( KnownAxi4WriteDataConfig conf 124 | , Show userType 125 | ) => 126 | Show (M2S_WriteData conf userType) 127 | 128 | deriving instance 129 | ( KnownAxi4WriteDataConfig conf 130 | , C.ShowX userType 131 | ) => 132 | C.ShowX (M2S_WriteData conf userType) 133 | 134 | deriving instance 135 | ( KnownAxi4WriteDataConfig conf 136 | , Eq userType 137 | ) => 138 | Eq (M2S_WriteData conf userType) 139 | 140 | deriving instance 141 | ( KnownAxi4WriteDataConfig conf 142 | , C.BitPack userType 143 | ) => 144 | C.BitPack (M2S_WriteData conf userType) 145 | 146 | deriving instance 147 | ( KnownAxi4WriteDataConfig conf 148 | , C.NFDataX userType 149 | ) => 150 | C.NFDataX (M2S_WriteData conf userType) 151 | 152 | instance IdleCircuit (Axi4WriteData dom conf userType) where 153 | idleFwd _ = C.pure M2S_NoWriteData 154 | idleBwd _ = C.pure S2M_WriteData{_wready = False} 155 | -------------------------------------------------------------------------------- /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, Eq, Generic) 90 | deriving anyclass (C.ShowX, 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 | , Eq (ResponseType (BKeepResponse conf)) 100 | , Show (ResponseType (BKeepResponse conf)) 101 | , C.ShowX (ResponseType (BKeepResponse conf)) 102 | , C.NFDataX (ResponseType (BKeepResponse conf)) 103 | , C.BitPack (ResponseType (BKeepResponse conf)) 104 | ) 105 | 106 | deriving instance 107 | ( KnownAxi4WriteResponseConfig conf 108 | , Eq userType 109 | ) => 110 | Eq (S2M_WriteResponse conf userType) 111 | 112 | deriving instance 113 | ( KnownAxi4WriteResponseConfig conf 114 | , Show userType 115 | ) => 116 | Show (S2M_WriteResponse conf userType) 117 | 118 | deriving instance 119 | ( KnownAxi4WriteResponseConfig conf 120 | , C.BitPack userType 121 | ) => 122 | C.BitPack (S2M_WriteResponse conf userType) 123 | 124 | deriving instance 125 | ( KnownAxi4WriteResponseConfig conf 126 | , C.ShowX userType 127 | ) => 128 | C.ShowX (S2M_WriteResponse conf userType) 129 | 130 | deriving instance 131 | ( KnownAxi4WriteResponseConfig conf 132 | , C.NFDataX userType 133 | ) => 134 | C.NFDataX (S2M_WriteResponse conf userType) 135 | 136 | instance IdleCircuit (Axi4WriteResponse dom conf userType) where 137 | idleFwd _ = pure S2M_NoWriteResponse 138 | idleBwd _ = pure $ M2S_WriteResponse False 139 | -------------------------------------------------------------------------------- /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 | {- | Conservative settings for `ExpectOptions`: 33 | - Reset for 30 cycles 34 | - Insert at most 10 stall moments 35 | - Every stall moment is at most 10 cycles long 36 | - Sample at most 1000 cycles 37 | - Automatically derive when to stop sampling empty samples using `expectedEmptyCycles`. 38 | -} 39 | defExpectOptions :: ExpectOptions 40 | defExpectOptions = 41 | ExpectOptions 42 | { -- XXX: These numbers are arbitrary, and should be adjusted to fit the 43 | -- protocol being tested. Annoyingly, upping these values will 44 | -- increase the time it takes to run the tests. This is because 45 | -- the test will run for at least the number of cycles specified 46 | -- in 'eoStopAfterEmpty'. 47 | eoStopAfterEmpty = Nothing 48 | , eoSampleMax = 1000 49 | , eoStallsMax = 10 50 | , eoConsecutiveStalls = 10 51 | , eoResetCycles = 30 52 | , eoDriveEarly = True 53 | , eoTimeoutMs = Nothing 54 | , eoTrace = False 55 | } 56 | 57 | instance (TestType a, C.KnownDomain dom) => Test (Df dom a) where 58 | expectN :: 59 | forall m. 60 | (HasCallStack, H.MonadTest m) => 61 | Proxy (Df dom a) -> 62 | ExpectOptions -> 63 | [Maybe a] -> 64 | m [a] 65 | expectN Proxy eOpts sampled = do 66 | go eOpts.eoSampleMax maxEmptyCycles sampled 67 | where 68 | maxEmptyCycles = expectedEmptyCycles eOpts 69 | go :: (HasCallStack) => Int -> Int -> [Maybe a] -> m [a] 70 | go _timeout _n [] = 71 | -- This really should not happen, protocols should produce data indefinitely 72 | error "unexpected end of signal" 73 | go 0 _ _ = 74 | -- Sample limit reached 75 | H.failWith 76 | Nothing 77 | ( "Sample limit reached after sampling " 78 | <> show eOpts.eoSampleMax 79 | <> " samples. " 80 | <> "Consider increasing 'eoSampleMax' in 'ExpectOptions'." 81 | ) 82 | go _ 0 _ = 83 | -- Saw enough valid samples, return to user 84 | pure [] 85 | go sampleTimeout _emptyTimeout (Just a : as) = 86 | -- Valid sample 87 | (a :) <$> go (sampleTimeout - 1) maxEmptyCycles as 88 | go sampleTimeout emptyTimeout (Nothing : as) = 89 | -- Empty sample 90 | go sampleTimeout (emptyTimeout - 1) as 91 | 92 | instance 93 | ( Test a 94 | , C.KnownNat n 95 | , 1 <= (n * SimulateChannels a) 96 | , 1 <= n 97 | ) => 98 | Test (C.Vec n a) 99 | where 100 | expectN :: 101 | forall m. 102 | (HasCallStack, H.MonadTest m) => 103 | Proxy (C.Vec n a) -> 104 | ExpectOptions -> 105 | C.Vec n (SimulateFwdType a) -> 106 | m (C.Vec n (ExpectType a)) 107 | -- TODO: This creates some pretty terrible error messages, as one 108 | -- TODO: simulate channel is checked at a time. 109 | expectN Proxy opts = mapM (expectN (Proxy @a) opts) 110 | 111 | instance 112 | ( Test a 113 | , Test b 114 | , 1 <= (SimulateChannels a + SimulateChannels b) 115 | ) => 116 | Test (a, b) 117 | where 118 | expectN :: 119 | forall m. 120 | (HasCallStack, H.MonadTest m) => 121 | Proxy (a, b) -> 122 | ExpectOptions -> 123 | (SimulateFwdType a, SimulateFwdType b) -> 124 | m (ExpectType a, ExpectType b) 125 | expectN Proxy opts (sampledA, sampledB) = do 126 | -- TODO: This creates some pretty terrible error messages, as one 127 | -- TODO: simulate channel is checked at a time. 128 | trimmedA <- expectN (Proxy @a) opts sampledA 129 | trimmedB <- expectN (Proxy @b) opts sampledB 130 | pure (trimmedA, trimmedB) 131 | 132 | -- XXX: We only generate up to 9 tuples instead of maxTupleSize because NFData 133 | -- instances are only available up to 9-tuples. 134 | -- see https://hackage.haskell.org/package/deepseq-1.5.1.0/docs/src/Control.DeepSeq.html#line-1125 135 | testTupleInstances 3 9 136 | -------------------------------------------------------------------------------- /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.Maybe (fromMaybe) 13 | import Data.Proxy 14 | import GHC.Stack (HasCallStack) 15 | import Protocols.Internal.Types 16 | 17 | -- hedgehog 18 | import Hedgehog qualified as H 19 | 20 | -- | Superclass class to reduce syntactical noise. 21 | class (NFData a, C.NFDataX a, C.ShowX a, C.Show a, Eq a) => TestType a 22 | 23 | instance (NFData a, C.NFDataX a, C.ShowX a, C.Show a, Eq a) => TestType a 24 | 25 | -- | Options for 'expectN' function. See individual fields for more information. 26 | data ExpectOptions = ExpectOptions 27 | { eoStopAfterEmpty :: Maybe Int 28 | -- ^ Explicitly control the number of samples empty samples simulate before we stop 29 | -- the simulation. When set to `Nothing`, this is derived using `expectedEmptyCycles`. 30 | , eoSampleMax :: Int 31 | -- ^ Produce an error if the circuit produces more than /n/ valid samples. This 32 | -- is used to terminate (potentially) infinitely running circuits. 33 | , eoStallsMax :: Int 34 | -- ^ Generate at most /n/ stall moments of zero or more cycles(set by 'eoConsecutiveStalls'). 35 | , eoConsecutiveStalls :: Int 36 | -- ^ Maximum number of consecutive stalls that are allowed to be inserted. 37 | , eoResetCycles :: Int 38 | -- ^ Ignore first /n/ cycles 39 | , eoDriveEarly :: Bool 40 | -- ^ Start driving the circuit with its reset asserted. Circuits should 41 | -- never acknowledge data while this is happening. 42 | , eoTimeoutMs :: Maybe Int 43 | -- ^ Terminate the test after /n/ milliseconds. 44 | , eoTrace :: Bool 45 | -- ^ Trace data generation for debugging purposes 46 | } 47 | 48 | -- | Default derivation of `eoStopAfterEmpty` when it is set to `Nothing`. 49 | expectedEmptyCycles :: ExpectOptions -> Int 50 | expectedEmptyCycles eOpts = 51 | -- +2 on `eoStallsMax` to account worst case left side stalling + right side stalling 52 | -- +1 on `eoConsecutiveStalls` to consume 1 sample after stalling 53 | -- +100 arbitrarily chosen to allow the circuit to have some internal latency. 54 | fromMaybe 55 | (eOpts.eoStallsMax * (eOpts.eoConsecutiveStalls + 1) + eOpts.eoResetCycles + 100) 56 | eOpts.eoStopAfterEmpty 57 | 58 | {- | Provides a way of comparing expected data with data produced by a 59 | protocol component. 60 | -} 61 | class 62 | ( Drivable a 63 | , TestType (SimulateFwdType a) 64 | , TestType (ExpectType a) 65 | , -- Foldable requirement on Vec :( 66 | 1 C.<= SimulateChannels a 67 | ) => 68 | Test a 69 | where 70 | -- | Trim each channel to the lengths given as the third argument. See 71 | -- result documentation for failure modes. 72 | expectN :: 73 | (HasCallStack, H.MonadTest m) => 74 | Proxy a -> 75 | -- | Options, see 'ExpectOptions' 76 | ExpectOptions -> 77 | -- | Raw sampled data 78 | SimulateFwdType a -> 79 | -- | Depending on "ExpectOptions", fails the test if: 80 | -- 81 | -- * Circuit produced less data than expected 82 | -- * Circuit produced more data than expected 83 | -- 84 | -- If it does not fail, /SimulateFwdType a/ will contain exactly the number 85 | -- of expected data packets. 86 | -- 87 | -- TODO: 88 | -- Should probably return a 'Vec (SimulateChannels) Failures' 89 | -- in order to produce pretty reports. 90 | m (ExpectType a) 91 | -------------------------------------------------------------------------------- /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, (deepErrorX "undefined ack", 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, (deepErrorX "undefined ack", 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 first 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, _) = (deepErrorX "undefined ack", 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 | zip4, 11 | zip5, 12 | unzip, 13 | unzip3, 14 | concat, 15 | unconcat, 16 | ) where 17 | 18 | -- base 19 | import Data.Tuple 20 | import Prelude () 21 | 22 | -- clash-prelude 23 | import Clash.Prelude hiding ( 24 | concat, 25 | split, 26 | unconcat, 27 | unzip, 28 | unzip3, 29 | zip, 30 | zip3, 31 | zip4, 32 | zip5, 33 | ) 34 | import Clash.Prelude qualified as C 35 | 36 | -- clash-protocols-base 37 | import Protocols.Internal (applyC) 38 | import Protocols.Plugin 39 | 40 | {- | "Bundle" together a 'Vec' of 'Circuit's into a 'Circuit' with 'Vec' input and output. 41 | The 'Circuit's all run in parallel. 42 | 43 | The inverse of 'vecCircuits' can not exist, as we can not guarantee that that the @n@th 44 | manager interface only depends on the @n@th subordinate interface. 45 | -} 46 | vecCircuits :: (C.KnownNat n) => C.Vec n (Circuit a b) -> Circuit (C.Vec n a) (C.Vec n b) 47 | vecCircuits fs = Circuit (\inps -> C.unzip $ f <$> fs <*> uncurry C.zip inps) 48 | where 49 | f (Circuit ff) = ff 50 | 51 | -- | Append two separate vectors of the same circuits into one vector of circuits 52 | append :: 53 | (C.KnownNat n0) => 54 | Circuit (C.Vec n0 circuit, C.Vec n1 circuit) (C.Vec (n0 + n1) circuit) 55 | append = applyC (uncurry (++)) splitAtI 56 | 57 | -- | Append three separate vectors of the same circuits into one vector of circuits 58 | append3 :: 59 | (C.KnownNat n0, C.KnownNat n1, KnownNat n2) => 60 | Circuit 61 | (C.Vec n0 circuit, C.Vec n1 circuit, C.Vec n2 circuit) 62 | (C.Vec (n0 + n1 + n2) circuit) 63 | append3 = applyC (uncurry3 append3Vec) split3Vec 64 | 65 | -- | Split a vector of circuits into two vectors of circuits. 66 | split :: 67 | (C.KnownNat n0) => 68 | Circuit (C.Vec (n0 + n1) circuit) (C.Vec n0 circuit, C.Vec n1 circuit) 69 | split = applyC splitAtI (uncurry (++)) 70 | 71 | -- | Split a vector of circuits into three vectors of circuits. 72 | split3 :: 73 | (C.KnownNat n0, C.KnownNat n1, C.KnownNat n2) => 74 | Circuit 75 | (C.Vec (n0 + n1 + n2) circuit) 76 | (C.Vec n0 circuit, C.Vec n1 circuit, C.Vec n2 circuit) 77 | split3 = applyC split3Vec (uncurry3 append3Vec) 78 | 79 | {- | Transforms two vectors of circuits into a vector of tuples of circuits. 80 | Only works if the two vectors have the same length. 81 | -} 82 | zip :: 83 | (C.KnownNat n) => 84 | Circuit (C.Vec n a, C.Vec n b) (C.Vec n (a, b)) 85 | zip = applyC (uncurry C.zip) C.unzip 86 | 87 | {- | Transforms three vectors of circuits into a vector of tuples of circuits. 88 | Only works if the three vectors have the same length. 89 | -} 90 | zip3 :: 91 | (C.KnownNat n) => 92 | Circuit (C.Vec n a, C.Vec n b, C.Vec n c) (C.Vec n (a, b, c)) 93 | zip3 = applyC (uncurry3 C.zip3) C.unzip3 94 | 95 | {- | Transforms four vectors of circuits into a vector of tuples of circuits. 96 | Only works if the four vectors have the same length. 97 | -} 98 | zip4 :: 99 | (C.KnownNat n) => 100 | Circuit (C.Vec n a, C.Vec n b, C.Vec n c, C.Vec n d) (C.Vec n (a, b, c, d)) 101 | zip4 = applyC (\(a, b, c, d) -> C.zip4 a b c d) unzip4 102 | 103 | {- | Transforms five vectors of circuits into a vector of tuples of circuits. 104 | Only works if the five vectors have the same length. 105 | -} 106 | zip5 :: 107 | (C.KnownNat n) => 108 | Circuit (C.Vec n a, C.Vec n b, C.Vec n c, C.Vec n d, C.Vec n e) (C.Vec n (a, b, c, d, e)) 109 | zip5 = applyC (\(a, b, c, d, e) -> C.zip5 a b c d e) unzip5 110 | 111 | -- | Unzip a vector of tuples of circuits into a tuple of vectors of circuits. 112 | unzip :: 113 | (C.KnownNat n) => 114 | Circuit (C.Vec n (a, b)) (C.Vec n a, C.Vec n b) 115 | unzip = applyC C.unzip (uncurry C.zip) 116 | 117 | -- | Unzip a vector of 3-tuples of circuits into a 3-tuple of vectors of circuits. 118 | unzip3 :: 119 | (C.KnownNat n) => 120 | Circuit (C.Vec n (a, b, c)) (C.Vec n a, C.Vec n b, C.Vec n c) 121 | unzip3 = applyC C.unzip3 (uncurry3 C.zip3) 122 | 123 | -- | transform a vector of vectors of circuits into a vector of circuits. 124 | concat :: 125 | (C.KnownNat n0, C.KnownNat n1) => 126 | Circuit (C.Vec n0 (C.Vec n1 circuit)) (C.Vec (n0 * n1) circuit) 127 | concat = applyC C.concat (C.unconcat SNat) 128 | 129 | -- | transform a vector of circuits into a vector of vectors of circuits. 130 | unconcat :: 131 | (C.KnownNat n, C.KnownNat m) => 132 | SNat m -> 133 | Circuit (C.Vec (n * m) circuit) (C.Vec n (C.Vec m circuit)) 134 | unconcat SNat = applyC (C.unconcat SNat) C.concat 135 | 136 | -- Internal utilities 137 | 138 | -- | Uncurry a function with three arguments into a function that takes a 3-tuple as argument. 139 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 140 | uncurry3 f (a, b, c) = f a b c 141 | 142 | -- Append three vectors of `a` into one vector of `a`. 143 | append3Vec :: 144 | (KnownNat n0, KnownNat n1, KnownNat n2) => 145 | C.Vec n0 a -> 146 | C.Vec n1 a -> 147 | C.Vec n2 a -> 148 | C.Vec (n0 + n1 + n2) a 149 | append3Vec v0 v1 v2 = v0 ++ v1 ++ v2 150 | 151 | -- Split a C.Vector of 3-tuples into three vectors of the same length. 152 | split3Vec :: 153 | (KnownNat n0, KnownNat n1, KnownNat n2) => 154 | C.Vec (n0 + n1 + n2) a -> 155 | (C.Vec n0 a, C.Vec n1 a, C.Vec n2 a) 156 | split3Vec v = (v0, v1, v2) 157 | where 158 | (v0, splitAtI -> (v1, v2)) = splitAtI v 159 | -------------------------------------------------------------------------------- /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 "extra" Data.List.Extra (unsnoc) 11 | 12 | import Hedgehog (Gen, 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 | prop_truncate_aborted_packets :: Property 48 | prop_truncate_aborted_packets = 49 | idWithModelSingleDomain 50 | @System 51 | defExpectOptions 52 | gen 53 | (exposeClockResetEnable model') 54 | (exposeClockResetEnable truncateAbortedPackets) 55 | where 56 | gen :: Gen [PacketStreamM2S 4 ()] 57 | gen = genPackets 0 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10)) 58 | 59 | model' packets = L.concatMap model (chunkByPacket packets) 60 | 61 | model :: [PacketStreamM2S 4 ()] -> [PacketStreamM2S 4 ()] 62 | model [] = [] 63 | model (x : xs) 64 | | x._abort = [x{_last = Just 0}] 65 | | otherwise = x : model xs 66 | 67 | tests :: TestTree 68 | tests = 69 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 70 | $ localOption 71 | (HedgehogTestLimit (Just 500)) 72 | $(testGroupGenerator) 73 | -------------------------------------------------------------------------------- /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 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 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 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 = Just 500} -- To account for empty cycles due to dropped packets 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 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 | packets :: [PacketStreamM2S 4 Int16] <- forAll gen 123 | 124 | let packetSize = 2 P.^ snatToInteger d12 125 | cfg = SimulationConfig 1 (2 * packetSize) False 126 | cktResult = simulateC ckt cfg (Just <$> packets) 127 | 128 | assert $ noGaps $ L.take (5 * maxInputSize) cktResult 129 | where 130 | noGaps :: [Maybe (PacketStreamM2S 4 Int16)] -> Bool 131 | noGaps (Just (PacketStreamM2S{_last = Nothing}) : Nothing : _) = False 132 | noGaps (_ : xs) = noGaps xs 133 | noGaps _ = True 134 | 135 | tests :: TestTree 136 | tests = 137 | localOption (mkTimeout 20_000_000 {- 20 seconds -}) 138 | $ localOption 139 | (HedgehogTestLimit (Just 500)) 140 | $(testGroupGenerator) 141 | -------------------------------------------------------------------------------- /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 "extra" 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 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 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 Unsafe.Coerce (unsafeCoerce) 5 | 6 | -- unordered-containers 7 | 8 | import Data.HashMap.Strict (HashMap) 9 | import Data.HashMap.Strict qualified as HashMap 10 | 11 | -- hashable 12 | import Data.Hashable (Hashable) 13 | 14 | -- clash-prelude 15 | 16 | import Clash.Prelude (type (<=)) 17 | import Clash.Prelude qualified as C 18 | 19 | -- extra 20 | import "extra" Data.List.Extra (transpose) 21 | import "extra" 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 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "circuit-notation": { 4 | "inputs": { 5 | "clash-compiler": [ 6 | "clash-compiler" 7 | ], 8 | "flake-utils": "flake-utils" 9 | }, 10 | "locked": { 11 | "lastModified": 1754654260, 12 | "narHash": "sha256-lnWz7cjZYkgH7IF1VvXy0n6xw+faNJbdrF/79QIieDo=", 13 | "owner": "cchalmers", 14 | "repo": "circuit-notation", 15 | "rev": "a99969b79df6752532792fd30482b83cf3285f52", 16 | "type": "github" 17 | }, 18 | "original": { 19 | "owner": "cchalmers", 20 | "repo": "circuit-notation", 21 | "type": "github" 22 | } 23 | }, 24 | "clash-compiler": { 25 | "inputs": { 26 | "flake-compat": "flake-compat", 27 | "flake-utils": "flake-utils_2", 28 | "ghc-tcplugins-extra": "ghc-tcplugins-extra", 29 | "ghc-typelits-extra": "ghc-typelits-extra", 30 | "ghc-typelits-knownnat": "ghc-typelits-knownnat", 31 | "ghc-typelits-natnormalise": "ghc-typelits-natnormalise", 32 | "nixpkgs": "nixpkgs" 33 | }, 34 | "locked": { 35 | "lastModified": 1754301255, 36 | "narHash": "sha256-dne2oWxOEosMYumUZZhc3c8NyJMdiqpb/xvd1saTp30=", 37 | "owner": "clash-lang", 38 | "repo": "clash-compiler", 39 | "rev": "6a0810496560e2ff2a0071f315afb573c12bba39", 40 | "type": "github" 41 | }, 42 | "original": { 43 | "owner": "clash-lang", 44 | "repo": "clash-compiler", 45 | "type": "github" 46 | } 47 | }, 48 | "flake-compat": { 49 | "flake": false, 50 | "locked": { 51 | "lastModified": 1696426674, 52 | "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", 53 | "owner": "edolstra", 54 | "repo": "flake-compat", 55 | "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", 56 | "type": "github" 57 | }, 58 | "original": { 59 | "owner": "edolstra", 60 | "repo": "flake-compat", 61 | "type": "github" 62 | } 63 | }, 64 | "flake-utils": { 65 | "inputs": { 66 | "systems": "systems" 67 | }, 68 | "locked": { 69 | "lastModified": 1731533236, 70 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 71 | "owner": "numtide", 72 | "repo": "flake-utils", 73 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 74 | "type": "github" 75 | }, 76 | "original": { 77 | "id": "flake-utils", 78 | "type": "indirect" 79 | } 80 | }, 81 | "flake-utils_2": { 82 | "inputs": { 83 | "systems": "systems_2" 84 | }, 85 | "locked": { 86 | "lastModified": 1726560853, 87 | "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", 88 | "owner": "numtide", 89 | "repo": "flake-utils", 90 | "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", 91 | "type": "github" 92 | }, 93 | "original": { 94 | "owner": "numtide", 95 | "repo": "flake-utils", 96 | "type": "github" 97 | } 98 | }, 99 | "flake-utils_3": { 100 | "inputs": { 101 | "systems": "systems_3" 102 | }, 103 | "locked": { 104 | "lastModified": 1731533236, 105 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 106 | "owner": "numtide", 107 | "repo": "flake-utils", 108 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 109 | "type": "github" 110 | }, 111 | "original": { 112 | "id": "flake-utils", 113 | "type": "indirect" 114 | } 115 | }, 116 | "ghc-tcplugins-extra": { 117 | "flake": false, 118 | "locked": { 119 | "lastModified": 1716385093, 120 | "narHash": "sha256-pXQoPP22TicWFwpWub9CX1J+rpOKfyX2IyzlCg1qG84=", 121 | "owner": "clash-lang", 122 | "repo": "ghc-tcplugins-extra", 123 | "rev": "702dda2095c66c4f5148a749c8b7dbcc8a09f5c1", 124 | "type": "github" 125 | }, 126 | "original": { 127 | "owner": "clash-lang", 128 | "repo": "ghc-tcplugins-extra", 129 | "type": "github" 130 | } 131 | }, 132 | "ghc-typelits-extra": { 133 | "flake": false, 134 | "locked": { 135 | "lastModified": 1716411282, 136 | "narHash": "sha256-YH03Ce+TEWKHGAm7BhynitZomfpYeKpqvZAviw8yEPA=", 137 | "owner": "clash-lang", 138 | "repo": "ghc-typelits-extra", 139 | "rev": "4dadc824a3ef9a511fcf6605167715a5a655ba0d", 140 | "type": "github" 141 | }, 142 | "original": { 143 | "owner": "clash-lang", 144 | "repo": "ghc-typelits-extra", 145 | "type": "github" 146 | } 147 | }, 148 | "ghc-typelits-knownnat": { 149 | "flake": false, 150 | "locked": { 151 | "lastModified": 1716408841, 152 | "narHash": "sha256-A2v6GkMtSJqZXpTwWfIcwshieyRySeR1bP+NogUHNoo=", 153 | "owner": "clash-lang", 154 | "repo": "ghc-typelits-knownnat", 155 | "rev": "2e57de3b709dab085fb1657cf73d4f5e833229ee", 156 | "type": "github" 157 | }, 158 | "original": { 159 | "owner": "clash-lang", 160 | "repo": "ghc-typelits-knownnat", 161 | "type": "github" 162 | } 163 | }, 164 | "ghc-typelits-natnormalise": { 165 | "flake": false, 166 | "locked": { 167 | "lastModified": 1716387676, 168 | "narHash": "sha256-G5p0NUy4CpjxGO1VNhb38fhkXESFPxGaZJM0qd6L74U=", 169 | "owner": "clash-lang", 170 | "repo": "ghc-typelits-natnormalise", 171 | "rev": "84f500a9735675e96253181939c3473a567f6f7a", 172 | "type": "github" 173 | }, 174 | "original": { 175 | "owner": "clash-lang", 176 | "repo": "ghc-typelits-natnormalise", 177 | "type": "github" 178 | } 179 | }, 180 | "nixpkgs": { 181 | "locked": { 182 | "lastModified": 1727089097, 183 | "narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=", 184 | "owner": "NixOS", 185 | "repo": "nixpkgs", 186 | "rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c", 187 | "type": "github" 188 | }, 189 | "original": { 190 | "owner": "NixOS", 191 | "ref": "nixpkgs-unstable", 192 | "repo": "nixpkgs", 193 | "type": "github" 194 | } 195 | }, 196 | "root": { 197 | "inputs": { 198 | "circuit-notation": "circuit-notation", 199 | "clash-compiler": "clash-compiler", 200 | "flake-utils": "flake-utils_3" 201 | } 202 | }, 203 | "systems": { 204 | "locked": { 205 | "lastModified": 1681028828, 206 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 207 | "owner": "nix-systems", 208 | "repo": "default", 209 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 210 | "type": "github" 211 | }, 212 | "original": { 213 | "owner": "nix-systems", 214 | "repo": "default", 215 | "type": "github" 216 | } 217 | }, 218 | "systems_2": { 219 | "locked": { 220 | "lastModified": 1681028828, 221 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 222 | "owner": "nix-systems", 223 | "repo": "default", 224 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 225 | "type": "github" 226 | }, 227 | "original": { 228 | "owner": "nix-systems", 229 | "repo": "default", 230 | "type": "github" 231 | } 232 | }, 233 | "systems_3": { 234 | "locked": { 235 | "lastModified": 1681028828, 236 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 237 | "owner": "nix-systems", 238 | "repo": "default", 239 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 240 | "type": "github" 241 | }, 242 | "original": { 243 | "owner": "nix-systems", 244 | "repo": "default", 245 | "type": "github" 246 | } 247 | } 248 | }, 249 | "root": "root", 250 | "version": 7 251 | } 252 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "A flake for the clash-protocols and clash-protocols-base"; 3 | inputs = { 4 | clash-compiler.url = "github:clash-lang/clash-compiler"; 5 | circuit-notation = { 6 | url = "github:cchalmers/circuit-notation"; 7 | inputs.clash-compiler.follows = "clash-compiler"; 8 | }; 9 | }; 10 | outputs = { self, flake-utils, clash-compiler, circuit-notation, ... }: 11 | flake-utils.lib.eachDefaultSystem (system: 12 | let 13 | # The package to expose as 'default' 14 | default-package = "clash-protocols"; 15 | # The 'default' version of ghc to use 16 | default-version = clash-compiler.ghcVersion.${system}; 17 | # A list of all ghc versions this package supports 18 | supported-versions = clash-compiler.supportedGhcVersions.${system}; 19 | 20 | all-overlays = builtins.listToAttrs (builtins.map (compiler-version: 21 | let 22 | # Remove the -fplugin and Setup.hs settings in the .cabal 23 | # For ghc9101+ these options don't matter, but for ghc964 and ghc982 this breaks installation 24 | # When entering the installPhase something (I'm not entirely sure what) goes wrong 25 | # between Nix and GHC, causing Setup.hs to get invoked with the wrong set of packages 26 | # (I think?). Removing the specific flags during installation fixes the issue for Nix, 27 | # whilst not breaking regular compilation. 28 | # 29 | # Do note that this patch only gets applied during *installation* and not *compilation* 30 | # That means these flags are still in place during compilation 31 | override-attrs = if compiler-version == "ghc964" || compiler-version == "ghc982" then 32 | fAttr: pAttr: { 33 | preInstall = pAttr.preInstall or "" + '' 34 | sed -i "/-fplugin GHC.TypeLits.Extra.Solver/,+2d" clash-protocols.cabal 35 | ''; 36 | } 37 | else 38 | {}; 39 | 40 | overlay = final: prev: { 41 | # Append the package set with clash-protocols* 42 | clash-protocols = (prev.developPackage { 43 | root = ./clash-protocols; 44 | overrides = _: _: final; 45 | # Remove me when https://github.com/clash-lang/clash-protocols/issues/131 46 | # has been solved 47 | modifier = drv: drv.overrideAttrs (_: { doCheck = false; }); 48 | }).overrideAttrs override-attrs; 49 | clash-protocols-base = prev.developPackage { 50 | root = ./clash-protocols-base; 51 | overrides = _: _: final; 52 | }; 53 | } // circuit-notation.overlays.${system}.${compiler-version} final prev; 54 | in 55 | { name = compiler-version; value = overlay; } 56 | ) supported-versions); 57 | 58 | all-hs-pkgs = builtins.mapAttrs (compiler-version: overlay: 59 | let 60 | pkgs = (import clash-compiler.inputs.nixpkgs { 61 | inherit system; 62 | }).extend clash-compiler.overlays.${compiler-version}; 63 | clash-pkgs = pkgs."clashPackages-${compiler-version}"; 64 | 65 | hs-pkgs = clash-pkgs.extend overlay; 66 | in 67 | hs-pkgs 68 | ) all-overlays; 69 | 70 | minimal-shell = hs-pkgs: hs-pkgs.shellFor { 71 | packages = p: [ 72 | p.clash-protocols 73 | p.clash-protocols-base 74 | ]; 75 | 76 | nativeBuildInputs = 77 | [ 78 | hs-pkgs.cabal-install 79 | hs-pkgs.cabal-plan 80 | hs-pkgs.fourmolu 81 | ] 82 | ; 83 | }; 84 | 85 | all-shells = clash-compiler.inputs.nixpkgs.lib.attrsets.concatMapAttrs (name: hs-pkgs: { 86 | # The difference between the `-minimal` and `-full` is the addition of HLS in the full version 87 | # This is because HLS is slow to compile and not everyone uses it 88 | # We default to using the `-minimal` version when `nix develop`ing 89 | "${name}-minimal" = minimal-shell hs-pkgs; 90 | "${name}-full" = (minimal-shell hs-pkgs).overrideAttrs (fAttr: pAttr: { 91 | nativeBuildInputs = pAttr.nativeBuildInputs ++ [ 92 | hs-pkgs.haskell-language-server 93 | ]; 94 | }); 95 | }) all-hs-pkgs; 96 | 97 | all-packages = builtins.mapAttrs (_: hs-pkgs: 98 | { 99 | clash-protocols = hs-pkgs.clash-protocols; 100 | clash-protocols-base = hs-pkgs.clash-protocols-base; 101 | 102 | default = hs-pkgs.${default-package}; 103 | }) all-hs-pkgs; 104 | in 105 | { 106 | # Expose the overlay of each supported version which adds clash-protocols(-base) 107 | # The base of the overlay is clash-pkgs 108 | overlays = all-overlays // { default = all-overlays.${default-version}; }; 109 | 110 | # A devShell for each supported version 111 | # 112 | # These can be invoked using `nix develop .#ghc9101-minimal` 113 | # 114 | # Please do note that if you work with Nix, you need to remove the `cabal.project` file at 115 | # the root of the directory! Cabal prioritizes local source overrides over Nix, which causes 116 | # the circuit-notation package to incorrectly fetched from Hackage rather than Nix. 117 | devShells = all-shells // { default = all-shells."${default-version}-minimal"; }; 118 | 119 | # The default directly refers to the default package of the default ghc version of this flake 120 | # All other entries aren't packages, they're a set of packages for each supported ghc version 121 | packages = all-packages // { default = all-packages.${default-version}.${default-package}; }; 122 | }); 123 | } 124 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------