diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 12917e3..5690298 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -66,6 +66,7 @@ jobs: cabal build all --write-ghc-environment-files=always ghc -Wall -Werror -iexample Example ghc -Wall -Werror -iexample Testing + ghc -Wall -Werror -iexample ValueCircuits - name: Test run: | diff --git a/CHANGELOG.md b/CHANGELOG.md index b009ea6..e504990 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,35 @@ # Revision history for `circuit-notations` +## 0.3.0.0 -- Unreleased + +* Add value-level ports via the new `SignalV` and `FwdV` markers in + `circuit` blocks. The circuit's logic is written over the values sampled + each clock cycle; the plugin lifts it back to the signal level with + `fmap`/`bundle`/`unbundle` and ties feedback loops with a lazy let + binding. The bus-level markers still bind the raw forward channel and mix + freely with value markers in one block; `Fwd` works on any bus, while the + bus-level `Signal` (and new `DSignal`) markers now additionally enforce + the bus type, which also drives type inference. See the README and + example/ValueCircuits.hs. + + **Breaking**: `ExternalNames` gained `signalTagName`, `fwdTagName` and + `dSignalTagName` fields, so custom plugins (e.g. clash-protocols style) + need to supply them — `defExternalNames` is now exported so they can be + record updates of the defaults. +* Add a per-GHC `checks` output to the flake, so `nix flake check` (or + `nix build .#checks..`) builds the package and runs all test + suites against every supported GHC. The CI nix job now uses it. The + error-location test suite skips itself (with a message) when the ambient + `ghc` has no circuit-notation package registered — as during a plain nix + build of the package, where it previously failed. +* Fix the source location of type errors on a bus. Since bus tagging was + introduced, such errors pointed at the end of the `circuit` block rather than + at the offending statement. Generated bindings are now located at their + circuit expression so GHC blames the right line. Generated bundle patterns + and expressions also take the span of the ports they bundle, so + whole-bundle errors (e.g. sharing a value-level variable across clock + domains) are blamed on the ports rather than on the head of the circuit. + ## 0.2.0.0 -- 2026-04-23 * Start of the changelog diff --git a/README.md b/README.md index b50bead..4e9d870 100644 --- a/README.md +++ b/README.md @@ -2,3 +2,77 @@ This is a plugin for manipulating circuits in clash with arrow notation. See example/Example.hs for example usage. Also see [clash-protocols](https://github.com/clash-lang/clash-protocols#). + +## Value-level ports (`SignalV` / `FwdV`) + +The `SignalV` and `FwdV` markers describe a circuit's logic over the *values +sampled each clock cycle* instead of over whole buses, right inside an +ordinary `circuit` block: + +- `SignalV n <- … -< …` binds `n` to the per-cycle value carried on that bus. +- `… -< SignalV e` injects the per-cycle value `e` back onto a bus. + +(The bus-level markers, which bind the raw forward channel, still exist and +can be mixed freely with value markers in one block: `Fwd` works on any bus, +while `Signal` and `DSignal` additionally enforce that the bus is a `Signal` +or `DSignal` — which also helps type inference, since it pins the bus type.) + +The two value markers differ in what buses they accept: + +- `SignalV x` asserts the bus *is* a `Signal dom a`; it pins the bus type + and so gives the best type inference (it works against fully generic + sub-circuits like `idC`). +- `FwdV x` samples (or drives) the forward channel of *any* signal-like + bus — any `SignalBus` instance: `Signal`s, `Vec`s and tuples of + signal-like buses (sampled as `Vec`s/tuples of values), and custom buses + given a one-line instance. In exchange, the bus type must be determined by + context (the circuit's signature or a concretely typed sub-circuit), and + pattern uses need a trivial backwards channel (`TrivialBwd (Bwd t)`). +- `DSignalV x` is `SignalV` for delayed signals (`DSignal dom d a`). The + delay index is part of the bus type, so everything in one logic group must + sit at the *same pipeline depth* (combining values from different stages + is a type error, like mixing clock domains), and since the lifted logic is + combinational, a group's outputs are produced at the delay its inputs are + sampled at. Groups at different depths can coexist in one block. Plain and + delayed values can't meet in one group; the plugin reports mixing them. + +Everything in between — the `let` bindings of the do block — is ordinary pure +Haskell, and feedback loops are written as ordinary recursive `let`s: + +```haskell +counter3 :: Circuit () (Signal dom Int) +counter3 = circuit do + SignalV n <- registerC 0 -< SignalV n' -- n :: Int (this cycle's value) + SignalV m <- registerC 8 -< SignalV m' -- m :: Int + let n' = n + 1 -- pure, value-level + m' = m + 1 + idC -< SignalV (n' + m') +``` + +The plugin collects the value-level bindings into pure functions, lifts them +to the signal level with `fmap` (using `bundle`/`unbundle` to group the +buses), and ties feedback knots with lazy let bindings. See +example/ValueCircuits.hs for more examples and the expansion of `counter3`. + +A single block can span several clock domains: the value-level bindings are +split into groups connected by shared variables, and each group is lifted +independently, so only buses whose values actually meet must share a clock +domain. Two independent counters on two different domains can live in one +block; making their values meet (e.g. `SignalV (n + m)`) is an +unsynchronized clock domain crossing and is rejected by the type checker +(cross between domains with explicit bus-level synchronizer circuits +instead). + +Notes: + +- Pattern match down to *exactly* the signal layer, no shallower; the + plugin cannot (yet) know which types contain signals, so the boundary has + to be explicit. Marking a bus with `SignalV` when it is not a `Signal` + (e.g. a `Vec` of signals) is a type error on the offending statement — + use `FwdV` to sample such buses whole. +- `let` statements that use value-level variables form the bodies of the + generated logic functions; `let`s that don't touch value land (e.g. a + let-bound sub-circuit) stay at the bus level and can be used with `-<`. +- The grouping is syntactic and conservative: shadowing a value-level name + inside a `let` can merge groups that wouldn't strictly need to share a + domain (never the other way around). diff --git a/circuit-notation.cabal b/circuit-notation.cabal index 849c128..e828865 100644 --- a/circuit-notation.cabal +++ b/circuit-notation.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: circuit-notation -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Source plugin for manipulating circuits in Clash using arrow notation description: Source plugin for manipulating circuits in Clash using arrow notation. @@ -62,7 +62,9 @@ test-suite library-testsuite default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: unittests.hs - other-modules: Example + other-modules: + Example + ValueCircuits hs-source-dirs: tests example @@ -71,3 +73,18 @@ test-suite library-testsuite base, circuit-notation, clash-prelude >=1.0, + +-- Checks that type errors on a bus point at the offending statement rather than +-- at the end of the circuit (see tests/fixtures/BusError.hs). +test-suite error-location + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: error-location.hs + hs-source-dirs: tests + build-depends: + base, + circuit-notation, + clash-prelude >=1.0, + directory, + filepath, + process, diff --git a/example/ValueCircuits.hs b/example/ValueCircuits.hs new file mode 100644 index 0000000..5f2fc84 --- /dev/null +++ b/example/ValueCircuits.hs @@ -0,0 +1,356 @@ +{- + ██████╗██╗██████╗ ██████╗██╗ ██╗██╗████████╗███████╗ +██╔════╝██║██╔══██╗██╔════╝██║ ██║██║╚══██╔══╝██╔════╝ +██║ ██║██████╔╝██║ ██║ ██║██║ ██║ ███████╗ +██║ ██║██╔══██╗██║ ██║ ██║██║ ██║ ╚════██║ +╚██████╗██║██║ ██║╚██████╗╚██████╔╝██║ ██║ ███████║ + ╚═════╝╚═╝╚═╝ ╚═╝ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝ ╚══════╝ + (C) 2020, Christopher Chalmers + +Examples of value-level ports (the 'SignalV' and 'FwdV' markers) in circuit +blocks. These are simulated and checked by tests/unittests.hs. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} +{-# OPTIONS -Wall #-} + +module ValueCircuits where + +import Circuit + +import Clash.Prelude +import Clash.Signal.Internal (Signal ((:-))) + +-- | A register as a circuit: the output bus carries the input bus delayed by +-- one cycle, starting with the given value. +registerC :: a -> Circuit (Signal dom a) (Signal dom a) +registerC a = Circuit $ \(s :-> ()) -> (() :-> (a :- s)) + +-- | Run a circuit whose buses have trivial backwards channels (such as +-- 'Signal' buses, or tuples and 'Vec's of them) by feeding it forward values. +simulateC :: TrivialBwd (Bwd b) => Circuit a b -> Fwd a -> Fwd b +simulateC c aFwd = let (_ :-> bFwd) = runCircuit c (aFwd :-> unitBwd) in bFwd + +-- Basic shapes --------------------------------------------------------- + +-- | Trivial pass-through: a single value in and a single value out, no +-- feedback. @a@ is the per-cycle 'Int' carried on the bus, not the bus +-- itself; no @bundle@/@unbundle@ is generated for single buses. +plusOne :: Circuit (Signal dom Int) (Signal dom Int) +plusOne = circuit \(SignalV a) -> do + idC -< SignalV (a + 1) + +-- | The same as 'plusOne' without a do block: a bare expression body. +plusOneBare :: Circuit (Signal dom Int) (Signal dom Int) +plusOneBare = circuit \(SignalV a) -> SignalV (a + 1) + +-- | The @FwdV@ marker also marks the value boundary, but works on /any/ +-- signal-like bus (any 'SignalBus' instance) rather than only literal +-- 'Signal's. The trade-off: the bus type must be determined by context +-- (here, the signature). +plusOneFwd :: Circuit (Signal dom Int) (Signal dom Int) +plusOneFwd = circuit \(FwdV a) -> do + idC -< FwdV (a + 1) + +-- | A whole 'Vec' of signal buses sampled as a single @Vec n Int@ value per +-- cycle (via the 'SignalBus' instance for 'Vec'). +vecSampleC :: Circuit (Vec 2 (Signal dom Int)) (Signal dom Int) +vecSampleC = circuit \(FwdV v) -> do + idC -< SignalV (sum v) + +-- | ... and emitted back as one: a @Vec 2 Int@ value drives both buses. +vecEmitC :: Circuit (Signal dom Int) (Vec 2 (Signal dom Int)) +vecEmitC = circuit \(SignalV a) -> do + idC -< FwdV (a :> (a + 1) :> Nil) + +-- | A whole tuple of signal-like buses sampled as a single tuple of values +-- per cycle (via the 'SignalBus' instances for tuples, which go up to +-- 12-tuples). +tupleSampleC + :: Circuit + (Signal dom Int, Vec 2 (Signal dom Int), Signal dom Int, Signal dom Int) + (Signal dom Int) +tupleSampleC = circuit \(FwdV (a, v, b, c)) -> do + idC -< SignalV (a + sum v + b + c) + +-- | @SignalV@ and @FwdV@ markers can meet in the same logic group. +mixedMarkersC :: Circuit (Signal dom Int, Vec 2 (Signal dom Int)) (Signal dom Int) +mixedMarkersC = circuit \(SignalV a, FwdV v) -> do + idC -< SignalV (a + sum v) + +-- | A custom signal-like bus: a stream of optionally-valid values with no +-- backpressure. The 'SignalBus' instance is all that's needed for @FwdV@ +-- markers to sample and drive it in circuit blocks. +-- The explicit result kind matters: without it, PolyKinds (on by default in +-- GHC2021+) would infer a poly-kinded @a@ for this empty data declaration. +data VStream (dom :: Domain) (a :: Type) +type instance Fwd (VStream dom a) = Signal dom (Maybe a) +type instance Bwd (VStream dom a) = () + +instance SignalBus (VStream dom a) where + type BusDom (VStream dom a) = dom + type SampleOf (VStream dom a) = Maybe a + sigFromBus = unBusTag + sigToBus = BusTag + +vstreamC :: Circuit (VStream dom Int) (VStream dom Int) +vstreamC = circuit \(FwdV m) -> do + idC -< FwdV (fmap (+ 1) m) + +-- | No value inputs at all: the logic is constant. +alwaysFive :: Circuit () (Signal dom Int) +alwaysFive = circuit do + idC -< SignalV (5 :: Int) + +-- | Two value inputs, one value output (a single @bundle@, no @unbundle@). +addC :: Circuit (Signal dom Int, Signal dom Int) (Signal dom Int) +addC = circuit \(SignalV a, SignalV b) -> do + idC -< SignalV (a + b) + +-- | One value input, two value outputs (a single @unbundle@, no @bundle@). +fanOutC :: Circuit (Signal dom Int) (Signal dom Int, Signal dom Int) +fanOutC = circuit \(SignalV a) -> do + idC -< (SignalV (a + 1), SignalV (a * 2)) + +-- | Values can be matched out of a bus carrying a compound type ... +splitC :: Circuit (Signal dom (Int, Bool)) (Signal dom Int, Signal dom Bool) +splitC = circuit \(SignalV (a, b)) -> do + idC -< (SignalV a, SignalV b) + +-- | ... and combined back onto one. +joinC :: Circuit (Signal dom Int, Signal dom Bool) (Signal dom (Int, Bool)) +joinC = circuit \(SignalV a, SignalV b) -> do + idC -< SignalV (a, b) + +-- | Ports nest like in ordinary circuit notation. +nestedTupleC :: Circuit ((Signal dom Int, Signal dom Int), Signal dom Int) (Signal dom Int) +nestedTupleC = circuit \((SignalV a, SignalV b), SignalV c) -> do + idC -< SignalV (a + b * c) + +-- | Value boundaries inside 'Vec' buses. +vecInC :: Circuit (Vec 2 (Signal dom Int)) (Signal dom Int) +vecInC = circuit \[SignalV a, SignalV b] -> do + idC -< SignalV (a - b) + +vecOutC :: Circuit (Signal dom Int) (Vec 2 (Signal dom Int)) +vecOutC = circuit \(SignalV a) -> do + idC -< [SignalV (a + 1), SignalV (a - 1)] + +-- | Ports crossing the value boundary can be given bus-level type +-- annotations like any other port. +annotatedC :: forall dom. Circuit (Signal dom Int) (Signal dom Int) +annotatedC = circuit \((SignalV a) :: Signal dom Int) -> do + idC -< SignalV (a + 1) + +-- Feedback ------------------------------------------------------------- + +-- | A single-register counter with a feedback loop. The register's input +-- @n'@ is defined in terms of its output @n@ by an ordinary recursive @let@; +-- the plugin ties the knot at the signal level. +counter :: Circuit () (Signal dom Int) +counter = circuit do + SignalV n <- registerC 0 -< SignalV n' + let n' = n + 1 + idC -< SignalV n + +-- | A Mealy-style accumulator: reads the per-cycle value off the input bus +-- and feeds back state through a register. Written with a @$@ chain. +accum :: Circuit (Signal dom Int) (Signal dom Int) +accum = circuit $ \(SignalV i) -> do + SignalV acc <- registerC 0 -< SignalV acc' + let acc' = acc + i + idC -< SignalV acc' + +-- | Two interleaved feedback loops (the canonical example from the design +-- notes). +counter3 :: Circuit () (Signal dom Int) +counter3 = circuit do + SignalV n <- registerC 0 -< SignalV n' + SignalV m <- registerC 8 -< SignalV m' + let n' = n + 1 + m' = m + 1 + idC -< SignalV (n' + m') + +-- | What 'counter3' expands to (modulo generated names). The value-level +-- bindings are collected into one pure function, @circuitLogic@, which is +-- lifted to the signal level with 'fmap'; 'bundle'/'unbundle' group the +-- buses and a lazy let binding ties the feedback knot. 'SigTag' is 'BusTag' +-- with its bus type pinned to a signal, which keeps inference going where +-- the non-injective 'Fwd' family would otherwise lose it. +counter3Expanded :: Circuit () (Signal dom Int) +counter3Expanded = TagCircuit $ \(~(BusTagBundle ()) :-> _) -> + let + circuitLogic = \(n, m) -> + let n' = n + 1 + m' = m + 1 + in (n', m', n' + m') + + (valOut0, valOut1, valOut2) = + unbundle (fmap circuitLogic (bundle (valIn0, valIn1))) + + (_ :-> SigTag valIn0) = runTagCircuit (registerC 0) (SigTag valOut0 :-> BusTag unitBwd) + (_ :-> SigTag valIn1) = runTagCircuit (registerC 8) (SigTag valOut1 :-> BusTag unitBwd) + in (BusTagBundle () :-> SigTag valOut2) + +-- | Compound state fed back through a /single/ register: a fibonacci +-- machine. The pair is destructured and rebuilt at the value level. +fibC :: Circuit () (Signal dom Int) +fibC = circuit do + SignalV (a, b) <- registerC (0, 1) -< SignalV (b, a + b) + idC -< SignalV a + +-- | A chain of registers: a three-deep shift register (no feedback, but a +-- value passes through several binds). +shift3 :: Circuit (Signal dom Int) (Signal dom Int) +shift3 = circuit \(SignalV i) -> do + SignalV a <- registerC 0 -< SignalV i + SignalV b <- registerC 0 -< SignalV a + SignalV c <- registerC 0 -< SignalV b + idC -< SignalV c + +-- | Three rotating registers plus the bus input: a four-way bundle on both +-- sides of the logic function. +rotate3 :: Circuit (Signal dom Int) (Signal dom Int) +rotate3 = circuit \(SignalV i) -> do + SignalV a <- registerC 1 -< SignalV a' + SignalV b <- registerC 2 -< SignalV b' + SignalV c <- registerC 3 -< SignalV c' + let a' = b + b' = c + c' = a + i + idC -< SignalV (a + b + c) + +-- Mixing value land and bus land ---------------------------------------- + +-- | Value-level and bus-level ports can be mixed: the second bus is routed +-- through untouched while the first is sampled and modified. +mixedC :: Circuit (Signal dom Int, Signal dom Int) (Signal dom Int, Signal dom Int) +mixedC = circuit \(SignalV a, b) -> do + idC -< (SignalV (a + 1), b) + +-- | As 'mixedC' but with a 'DF' bus (whose backwards channel is not +-- trivial) routed through. +mixedDfC :: Circuit (Signal dom Int, DF dom Bool) (Signal dom Int, DF dom Bool) +mixedDfC = circuit \(SignalV a, df) -> do + idC -< (SignalV (a + 1), df) + +-- | Bus-level markers (@Fwd@/@Signal@, which bind the raw forward channel) +-- and value-level markers (@FwdV@/@SignalV@) can be used side by side in +-- one block: here the 'Vec' bus is rearranged at the bus level while the +-- signal is sampled. +mixedLevelsC :: Circuit (Vec 2 (Signal dom Int), Signal dom Int) (Vec 2 (Signal dom Int), Signal dom Int) +mixedLevelsC = circuit \(Fwd v, SignalV a) -> do + idC -< (Fwd (rotateLeftS v d1), SignalV (a + 1)) + +-- | A bus created from a value can be multicast like any other bus. +multicastC :: Circuit (Signal dom Int) (Signal dom Int, Signal dom Int) +multicastC = circuit \(SignalV a) -> do + b <- idC -< SignalV (a + 1) + idC -< (b, b) + +-- | Without any value-level markers this is just ordinary circuit notation. +passthrough :: Circuit (Signal dom Int) (Signal dom Int) +passthrough = circuit \a -> a + +-- Delayed signals -------------------------------------------------------- +-- +-- @DSignalV@ marks the value boundary on 'DSignal' buses. The generated +-- @DSigTag@ pins the bus type /including the delay index/, and a delayed +-- group's bundle unifies the delays of everything in it: all values that +-- meet must come from (and go to) buses at the same pipeline depth. The +-- lifted logic is combinational, so a group's outputs are produced at the +-- same delay its inputs are sampled at. Groups at different delays can +-- coexist in one block. + +-- | A delayed register: the output is one cycle (and one delay index) +-- behind the input. +dregisterC :: a -> Circuit (DSignal dom d a) (DSignal dom (d + 1) a) +dregisterC a = Circuit $ \(s :-> ()) -> (() :-> unsafeFromSignal (a :- toSignal s)) + +-- | Delay-polymorphic pass-through: works at any pipeline depth, and pins +-- input and output to the /same/ depth. +dplusOne :: Circuit (DSignal dom d Int) (DSignal dom d Int) +dplusOne = circuit \(DSignalV a) -> do + idC -< DSignalV (a + 1) + +-- | The bus-level @DSignal@ marker: binds the raw delayed signal (here +-- mapped over directly) while enforcing that the bus is a 'DSignal'. The +-- bus-level @Signal@ marker enforces 'Signal' the same way; @Fwd@ remains +-- the generic bus-level marker. +dmapC :: Circuit (DSignal dom d Int) (DSignal dom d Int) +dmapC = circuit \(DSignal s) -> do + idC -< DSignal (fmap (+ 1) s) + +-- | Two delayed values meeting in one group: their buses must agree on the +-- delay (and domain), which the signature expresses with a single @d@. +daddC :: Circuit (DSignal dom d Int, DSignal dom d Int) (DSignal dom d Int) +daddC = circuit \(DSignalV a, DSignalV b) -> do + idC -< DSignalV (a + b) + +-- | A two-stage pipeline: the @i@ group sits at delay @d@ and the @a@ group +-- at delay @d + 1@ -- two value groups at different pipeline depths in one +-- block, linked by the delayed register at the bus level. +dpipeC :: Circuit (DSignal dom d Int) (DSignal dom (d + 1) Int) +dpipeC = circuit \(DSignalV i) -> do + DSignalV a <- dregisterC 0 -< DSignalV (i + 1) + idC -< DSignalV (a * 2) + +-- Multiple clock domains ------------------------------------------------- +-- +-- The plugin splits the value-level logic into groups connected by shared +-- variables and lifts each group with its own fmap/bundle/unbundle, so only +-- buses whose values actually meet must share a clock domain. Sharing a +-- value across domains is an (unsynchronized) clock domain crossing and is +-- rejected by the type checker. + +-- | Two independently enabled counters in one block, on two /different/ +-- clock domains: nothing forces @domA@ and @domB@ together. +dualCounter :: Circuit (Signal domA Bool, Signal domB Bool) (Signal domA Int, Signal domB Int) +dualCounter = circuit \(SignalV enA, SignalV enB) -> do + SignalV n <- registerC 0 -< SignalV (if enA then n + 1 else n) + SignalV m <- registerC 0 -< SignalV (if enB then m + 1 else m) + idC -< (SignalV n, SignalV m) + +-- | Two independent accumulators, each reading values off its own input +-- bus, on different clock domains. +dualAccum :: Circuit (Signal domA Int, Signal domB Int) (Signal domA Int, Signal domB Int) +dualAccum = circuit \(SignalV i, SignalV j) -> do + SignalV a <- registerC 0 -< SignalV (a + i) + SignalV b <- registerC 0 -< SignalV (b + j) + idC -< (SignalV a, SignalV b) + +-- | Lets that don't touch any value-level variable stay at the bus level, +-- so sub-circuits can be bound in a let and used with @-<@. +busLevelLet :: Circuit (Signal dom Int) (Signal dom Int) +busLevelLet = circuit \(SignalV x) -> do + let inc = plusOne + SignalV y <- inc -< SignalV (x + 1) + idC -< SignalV (y * 2) + +-- Nesting --------------------------------------------------------------- + +-- | A value-level circuit used as a sub-circuit inside a bus-level one. +nestedSInCircuit :: Circuit (Signal dom Int) (Signal dom Int) +nestedSInCircuit = circuit $ \a -> do + b <- (circuit \(SignalV x) -> do idC -< SignalV (x * 2)) -< a + idC -< b + +-- | A bus-level circuit used as a sub-circuit inside a value-level one. +nestedCircuitInS :: Circuit (Signal dom Int) (Signal dom Int) +nestedCircuitInS = circuit \(SignalV x) -> do + SignalV y <- (circuit \b -> b) -< SignalV (x + 1) + idC -< SignalV (y * 3) + +-- | A value-level circuit inside another value-level circuit. +nestedSInS :: Circuit (Signal dom Int) (Signal dom Int) +nestedSInS = circuit \(SignalV x) -> do + SignalV y <- (circuit \(SignalV a) -> do idC -< SignalV (a + 1)) -< SignalV x + idC -< SignalV (y * 2) diff --git a/flake.nix b/flake.nix index ff7d5f4..615ba78 100644 --- a/flake.nix +++ b/flake.nix @@ -19,6 +19,18 @@ circuit-notation = prev.developPackage { root = ./.; overrides = _: _: final; + # The error-location test shells out to `ghc` to compile a + # fixture with the plugin enabled (see tests/error-location.hs). + # During the package's own check phase circuit-notation isn't + # registered in any package database yet, so that `ghc` couldn't + # find the plugin. Point GHC_PACKAGE_PATH (via the builder's + # NIX_GHC_PACKAGE_PATH_FOR_TEST hook) at the in-place package db + # so the test runs for real, not just under cabal in CI. + modifier = drv: drv.overrideAttrs (old: { + preCheck = (old.preCheck or "") + '' + export NIX_GHC_PACKAGE_PATH_FOR_TEST="$PWD/dist/package.conf.inplace:$packageConfDir:" + ''; + }); }; }; in diff --git a/src/Circuit.hs b/src/Circuit.hs index 871a481..21323b8 100644 --- a/src/Circuit.hs +++ b/src/Circuit.hs @@ -74,9 +74,39 @@ type instance Bwd (a,b) = (Bwd a, Bwd b) type instance Fwd (a,b,c) = (Fwd a, Fwd b, Fwd c) type instance Bwd (a,b,c) = (Bwd a, Bwd b, Bwd c) +type instance Fwd (a,b,c,d) = (Fwd a, Fwd b, Fwd c, Fwd d) +type instance Bwd (a,b,c,d) = (Bwd a, Bwd b, Bwd c, Bwd d) + +type instance Fwd (a,b,c,d,e) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e) +type instance Bwd (a,b,c,d,e) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e) + +type instance Fwd (a,b,c,d,e,f) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f) +type instance Bwd (a,b,c,d,e,f) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f) + +type instance Fwd (a,b,c,d,e,f,g) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f, Fwd g) +type instance Bwd (a,b,c,d,e,f,g) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f, Bwd g) + +type instance Fwd (a,b,c,d,e,f,g,h) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f, Fwd g, Fwd h) +type instance Bwd (a,b,c,d,e,f,g,h) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f, Bwd g, Bwd h) + +type instance Fwd (a,b,c,d,e,f,g,h,i) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f, Fwd g, Fwd h, Fwd i) +type instance Bwd (a,b,c,d,e,f,g,h,i) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f, Bwd g, Bwd h, Bwd i) + +type instance Fwd (a,b,c,d,e,f,g,h,i,j) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f, Fwd g, Fwd h, Fwd i, Fwd j) +type instance Bwd (a,b,c,d,e,f,g,h,i,j) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f, Bwd g, Bwd h, Bwd i, Bwd j) + +type instance Fwd (a,b,c,d,e,f,g,h,i,j,k) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f, Fwd g, Fwd h, Fwd i, Fwd j, Fwd k) +type instance Bwd (a,b,c,d,e,f,g,h,i,j,k) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f, Bwd g, Bwd h, Bwd i, Bwd j, Bwd k) + +type instance Fwd (a,b,c,d,e,f,g,h,i,j,k,l) = (Fwd a, Fwd b, Fwd c, Fwd d, Fwd e, Fwd f, Fwd g, Fwd h, Fwd i, Fwd j, Fwd k, Fwd l) +type instance Bwd (a,b,c,d,e,f,g,h,i,j,k,l) = (Bwd a, Bwd b, Bwd c, Bwd d, Bwd e, Bwd f, Bwd g, Bwd h, Bwd i, Bwd j, Bwd k, Bwd l) + type instance Fwd (Signal dom a) = Signal dom a type instance Bwd (Signal dom a) = () +type instance Fwd (DSignal dom d a) = DSignal dom d a +type instance Bwd (DSignal dom d a) = () + -- | Circuit type. newtype Circuit a b = Circuit { runCircuit :: CircuitT a b } type CircuitT a b = (Fwd a :-> Bwd b) -> (Bwd a :-> Fwd b) @@ -140,6 +170,12 @@ instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i, TrivialBwd j) => TrivialBwd (a,b,c,d,e,f,g,h,i,j) where unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd) +instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i, TrivialBwd j, TrivialBwd k) => TrivialBwd (a,b,c,d,e,f,g,h,i,j,k) where + unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd) + +instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i, TrivialBwd j, TrivialBwd k, TrivialBwd l) => TrivialBwd (a,b,c,d,e,f,g,h,i,j,k,l) where + unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd) + instance TrivialBwd a => TrivialBwd (BusTag t a) where unitBwd = BusTag unitBwd @@ -198,6 +234,16 @@ instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j) = BusTag (a, b, c, d, e, f, g, h, i, j) taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i, j)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j) +instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti, tj, tk) (a, b, c, d, e, f, g, h, i, j, k) where + type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti, tj, tk) (a, b, c, d, e, f, g, h, i, j, k) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h, BusTag ti i, BusTag tj j, BusTag tk k) + taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j, BusTag k) = BusTag (a, b, c, d, e, f, g, h, i, j, k) + taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i, j, k)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j, BusTag k) + +instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti, tj, tk, tl) (a, b, c, d, e, f, g, h, i, j, k, l) where + type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti, tj, tk, tl) (a, b, c, d, e, f, g, h, i, j, k, l) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h, BusTag ti i, BusTag tj j, BusTag tk k, BusTag tl l) + taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j, BusTag k, BusTag l) = BusTag (a, b, c, d, e, f, g, h, i, j, k, l) + taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i, j, k, l)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j, BusTag k, BusTag l) + instance BusTagBundle (Vec n t) (Vec n a) where type BusTagUnbundled (Vec n t) (Vec n a) = Vec n (BusTag t a) taggedBundle = BusTag . fmap unBusTag @@ -207,3 +253,319 @@ pattern BusTagBundle :: BusTagBundle t a => BusTagUnbundled t a -> BusTag t a pattern BusTagBundle a <- (taggedUnbundle -> a) where BusTagBundle a = taggedBundle a {-# COMPLETE BusTagBundle #-} + +-- | A tagged 'Signal' bus. Used by the plugin for @Signal@ markers at the +-- value boundary of circuit blocks: matching or constructing with +-- 'SigTag' pins the bus type itself (the tag) to be a 'Signal', which +-- drives type inference. Since 'Fwd' is not injective, plain 'BusTag' would +-- leave the bus type ambiguous and type inference for nested circuits would +-- fail. +pattern SigTag :: Signal dom a -> BusTag (Signal dom a) (Signal dom a) +pattern SigTag s = BusTag s +{-# COMPLETE SigTag #-} + +-- | Like 'SigTag' but for delayed signals, used for @DSignalV@ markers: +-- pins the bus type to be a 'DSignal', /including its delay index/. The +-- markers of one logic group all flow through one (delayed) bundle, so a +-- group's buses must agree on the delay as well as the domain — combining +-- values from different pipeline stages is rejected by the type checker. +-- Since the lifted logic is combinational, the group's outputs are produced +-- at the same delay its inputs are sampled at. +pattern DSigTag :: DSignal dom d a -> BusTag (DSignal dom d a) (DSignal dom d a) +pattern DSigTag s = BusTag s +{-# COMPLETE DSigTag #-} + +-- | Buses whose forward channel carries a single value per clock cycle, +-- i.e. is convertible to a single 'Signal'. The @Fwd@ markers at the value +-- boundary of @circuit@ blocks work on any such bus: 'Signal's themselves, +-- 'Vec's and tuples of signal-like buses (all in the same domain), and any +-- custom bus given an instance. +class SignalBus t where + type BusDom t :: Domain + type SampleOf t + -- | Sample the forward channel of a tagged bus as a signal of values. + sigFromBus :: BusTag t (Fwd t) -> Signal (BusDom t) (SampleOf t) + -- | Drive the forward channel of a tagged bus from a signal of values. + sigToBus :: Signal (BusDom t) (SampleOf t) -> BusTag t (Fwd t) + +instance SignalBus (Signal dom a) where + type BusDom (Signal dom a) = dom + type SampleOf (Signal dom a) = a + sigFromBus = unBusTag + sigToBus = BusTag + +-- | A 'Vec' of signal-like buses is sampled as a 'Vec' of their values. +instance (SignalBus t, KnownNat n) => SignalBus (Vec n t) where + type BusDom (Vec n t) = BusDom t + type SampleOf (Vec n t) = Vec n (SampleOf t) + sigFromBus (BusTag v) = bundle (map (\f -> sigFromBus (BusTag f :: BusTag t (Fwd t))) v) + sigToBus s = BusTag (map (\x -> unBusTag (sigToBus x :: BusTag t (Fwd t))) (unbundle s)) + +instance (SignalBus a, SignalBus b, BusDom a ~ BusDom b) => SignalBus (a, b) where + type BusDom (a, b) = BusDom a + type SampleOf (a, b) = (SampleOf a, SampleOf b) + sigFromBus (BusTag (fa, fb)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) ) + sigToBus vs = case unbundle vs of + (va, vb) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) ) + +instance (SignalBus a, SignalBus b, SignalBus c, BusDom a ~ BusDom b, BusDom b ~ BusDom c) + => SignalBus (a, b, c) where + type BusDom (a, b, c) = BusDom a + type SampleOf (a, b, c) = (SampleOf a, SampleOf b, SampleOf c) + sigFromBus (BusTag (fa, fb, fc)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d ) + => SignalBus (a, b, c, d) where + type BusDom (a, b, c, d) = BusDom a + type SampleOf (a, b, c, d) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d) + sigFromBus (BusTag (fa, fb, fc, fd)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e ) + => SignalBus (a, b, c, d, e) where + type BusDom (a, b, c, d, e) = BusDom a + type SampleOf (a, b, c, d, e) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e) + sigFromBus (BusTag (fa, fb, fc, fd, fe)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f ) + => SignalBus (a, b, c, d, e, f) where + type BusDom (a, b, c, d, e, f) = BusDom a + type SampleOf (a, b, c, d, e, f) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f, SignalBus g + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f, BusDom f ~ BusDom g ) + => SignalBus (a, b, c, d, e, f, g) where + type BusDom (a, b, c, d, e, f, g) = BusDom a + type SampleOf (a, b, c, d, e, f, g) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f, SampleOf g) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff, fg)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) + , sigFromBus (BusTag fg :: BusTag g (Fwd g)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf, vg) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) + , unBusTag (sigToBus vg :: BusTag g (Fwd g)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f, SignalBus g, SignalBus h + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f, BusDom f ~ BusDom g, BusDom g ~ BusDom h ) + => SignalBus (a, b, c, d, e, f, g, h) where + type BusDom (a, b, c, d, e, f, g, h) = BusDom a + type SampleOf (a, b, c, d, e, f, g, h) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f, SampleOf g, SampleOf h) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff, fg, fh)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) + , sigFromBus (BusTag fg :: BusTag g (Fwd g)) + , sigFromBus (BusTag fh :: BusTag h (Fwd h)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf, vg, vh) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) + , unBusTag (sigToBus vg :: BusTag g (Fwd g)) + , unBusTag (sigToBus vh :: BusTag h (Fwd h)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f, SignalBus g, SignalBus h, SignalBus i + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f, BusDom f ~ BusDom g, BusDom g ~ BusDom h, BusDom h ~ BusDom i ) + => SignalBus (a, b, c, d, e, f, g, h, i) where + type BusDom (a, b, c, d, e, f, g, h, i) = BusDom a + type SampleOf (a, b, c, d, e, f, g, h, i) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f, SampleOf g, SampleOf h, SampleOf i) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff, fg, fh, fi)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) + , sigFromBus (BusTag fg :: BusTag g (Fwd g)) + , sigFromBus (BusTag fh :: BusTag h (Fwd h)) + , sigFromBus (BusTag fi :: BusTag i (Fwd i)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf, vg, vh, vi) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) + , unBusTag (sigToBus vg :: BusTag g (Fwd g)) + , unBusTag (sigToBus vh :: BusTag h (Fwd h)) + , unBusTag (sigToBus vi :: BusTag i (Fwd i)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f, SignalBus g, SignalBus h, SignalBus i, SignalBus j + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f, BusDom f ~ BusDom g, BusDom g ~ BusDom h, BusDom h ~ BusDom i, BusDom i ~ BusDom j ) + => SignalBus (a, b, c, d, e, f, g, h, i, j) where + type BusDom (a, b, c, d, e, f, g, h, i, j) = BusDom a + type SampleOf (a, b, c, d, e, f, g, h, i, j) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f, SampleOf g, SampleOf h, SampleOf i, SampleOf j) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff, fg, fh, fi, fj)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) + , sigFromBus (BusTag fg :: BusTag g (Fwd g)) + , sigFromBus (BusTag fh :: BusTag h (Fwd h)) + , sigFromBus (BusTag fi :: BusTag i (Fwd i)) + , sigFromBus (BusTag fj :: BusTag j (Fwd j)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf, vg, vh, vi, vj) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) + , unBusTag (sigToBus vg :: BusTag g (Fwd g)) + , unBusTag (sigToBus vh :: BusTag h (Fwd h)) + , unBusTag (sigToBus vi :: BusTag i (Fwd i)) + , unBusTag (sigToBus vj :: BusTag j (Fwd j)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f, SignalBus g, SignalBus h, SignalBus i, SignalBus j, SignalBus k + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f, BusDom f ~ BusDom g, BusDom g ~ BusDom h, BusDom h ~ BusDom i, BusDom i ~ BusDom j, BusDom j ~ BusDom k ) + => SignalBus (a, b, c, d, e, f, g, h, i, j, k) where + type BusDom (a, b, c, d, e, f, g, h, i, j, k) = BusDom a + type SampleOf (a, b, c, d, e, f, g, h, i, j, k) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f, SampleOf g, SampleOf h, SampleOf i, SampleOf j, SampleOf k) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff, fg, fh, fi, fj, fk)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) + , sigFromBus (BusTag fg :: BusTag g (Fwd g)) + , sigFromBus (BusTag fh :: BusTag h (Fwd h)) + , sigFromBus (BusTag fi :: BusTag i (Fwd i)) + , sigFromBus (BusTag fj :: BusTag j (Fwd j)) + , sigFromBus (BusTag fk :: BusTag k (Fwd k)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf, vg, vh, vi, vj, vk) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) + , unBusTag (sigToBus vg :: BusTag g (Fwd g)) + , unBusTag (sigToBus vh :: BusTag h (Fwd h)) + , unBusTag (sigToBus vi :: BusTag i (Fwd i)) + , unBusTag (sigToBus vj :: BusTag j (Fwd j)) + , unBusTag (sigToBus vk :: BusTag k (Fwd k)) ) + +instance + ( SignalBus a, SignalBus b, SignalBus c, SignalBus d, SignalBus e, SignalBus f, SignalBus g, SignalBus h, SignalBus i, SignalBus j, SignalBus k, SignalBus l + , BusDom a ~ BusDom b, BusDom b ~ BusDom c, BusDom c ~ BusDom d, BusDom d ~ BusDom e, BusDom e ~ BusDom f, BusDom f ~ BusDom g, BusDom g ~ BusDom h, BusDom h ~ BusDom i, BusDom i ~ BusDom j, BusDom j ~ BusDom k, BusDom k ~ BusDom l ) + => SignalBus (a, b, c, d, e, f, g, h, i, j, k, l) where + type BusDom (a, b, c, d, e, f, g, h, i, j, k, l) = BusDom a + type SampleOf (a, b, c, d, e, f, g, h, i, j, k, l) = (SampleOf a, SampleOf b, SampleOf c, SampleOf d, SampleOf e, SampleOf f, SampleOf g, SampleOf h, SampleOf i, SampleOf j, SampleOf k, SampleOf l) + sigFromBus (BusTag (fa, fb, fc, fd, fe, ff, fg, fh, fi, fj, fk, fl)) = bundle + ( sigFromBus (BusTag fa :: BusTag a (Fwd a)) + , sigFromBus (BusTag fb :: BusTag b (Fwd b)) + , sigFromBus (BusTag fc :: BusTag c (Fwd c)) + , sigFromBus (BusTag fd :: BusTag d (Fwd d)) + , sigFromBus (BusTag fe :: BusTag e (Fwd e)) + , sigFromBus (BusTag ff :: BusTag f (Fwd f)) + , sigFromBus (BusTag fg :: BusTag g (Fwd g)) + , sigFromBus (BusTag fh :: BusTag h (Fwd h)) + , sigFromBus (BusTag fi :: BusTag i (Fwd i)) + , sigFromBus (BusTag fj :: BusTag j (Fwd j)) + , sigFromBus (BusTag fk :: BusTag k (Fwd k)) + , sigFromBus (BusTag fl :: BusTag l (Fwd l)) ) + sigToBus vs = case unbundle vs of + (va, vb, vc, vd, ve, vf, vg, vh, vi, vj, vk, vl) -> BusTag + ( unBusTag (sigToBus va :: BusTag a (Fwd a)) + , unBusTag (sigToBus vb :: BusTag b (Fwd b)) + , unBusTag (sigToBus vc :: BusTag c (Fwd c)) + , unBusTag (sigToBus vd :: BusTag d (Fwd d)) + , unBusTag (sigToBus ve :: BusTag e (Fwd e)) + , unBusTag (sigToBus vf :: BusTag f (Fwd f)) + , unBusTag (sigToBus vg :: BusTag g (Fwd g)) + , unBusTag (sigToBus vh :: BusTag h (Fwd h)) + , unBusTag (sigToBus vi :: BusTag i (Fwd i)) + , unBusTag (sigToBus vj :: BusTag j (Fwd j)) + , unBusTag (sigToBus vk :: BusTag k (Fwd k)) + , unBusTag (sigToBus vl :: BusTag l (Fwd l)) ) + +-- | Like 'SigTag' but for any signal-like bus. Used by the plugin for @Fwd@ +-- markers at the value boundary of @circuit@ blocks. Unlike 'SigTag' it +-- cannot drive type inference (several buses can share a forward type), so +-- the bus type has to be determined by context, e.g. the circuit's +-- signature or a concretely typed sub-circuit. +pattern FwdTag :: SignalBus t => Signal (BusDom t) (SampleOf t) -> BusTag t (Fwd t) +pattern FwdTag s <- (sigFromBus -> s) where + FwdTag s = sigToBus s +{-# COMPLETE FwdTag #-} diff --git a/src/CircuitNotation.hs b/src/CircuitNotation.hs index de1220a..134686b 100644 --- a/src/CircuitNotation.hs +++ b/src/CircuitNotation.hs @@ -34,6 +34,7 @@ module CircuitNotation , mkPlugin , thName , ExternalNames (..) + , defExternalNames , Direction(..) ) where @@ -41,10 +42,15 @@ module CircuitNotation import Control.Exception import qualified Data.Data as Data import Data.Default +import Data.List (partition, sort, sortOn) import Data.Maybe (fromMaybe) import System.IO.Unsafe import Data.Typeable +-- containers +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + -- ghc import qualified Language.Haskell.TH as TH import qualified GHC @@ -92,7 +98,8 @@ import GHC.Types.Unique.Map.Extra #endif -- clash-prelude -import Clash.Prelude (Vec((:>), Nil)) +import Clash.Prelude (Vec((:>), Nil), bundle, unbundle) +import qualified Clash.Signal.Delayed.Bundle as DBundle -- lens import qualified Control.Lens as L @@ -211,14 +218,54 @@ data PortName = PortName SrcSpanAnnA GHC.FastString instance Show PortName where show (PortName _ fs) = GHC.unpackFS fs +-- | Which keyword marked a port. +-- +-- The bus-level markers bind/inject the raw forward channel: @Fwd@ works on +-- any bus, while @Signal@ and @DSignal@ additionally /enforce/ (via the +-- concrete @SigTag@/@DSigTag@, which also drives type inference) that the +-- bus is a 'Signal' or @DSignal@ respectively. +-- +-- The @...V@ markers mark the /value/ boundary, binding or injecting the +-- per-cycle value: @SignalV@ and @DSignalV@ assert the bus type like their +-- bus-level counterparts, while @FwdV@ samples the forward channel of any +-- signal-like bus (generating the class-constrained @FwdTag@, which +-- requires the bus type to be determined by context). +data SigMarker + = SignalMarker | FwdMarker | DSignalMarker + | SignalVMarker | FwdVMarker | DSignalVMarker + +-- | Is this marker a value boundary (@SignalV@/@FwdV@/@DSignalV@)? +isValueMarker :: SigMarker -> Bool +isValueMarker = \case + SignalVMarker -> True + FwdVMarker -> True + DSignalVMarker -> True + _ -> False + +-- | Value groups come in two flavors, lifted with the matching bundle: +-- plain signal values (@SignalV@/@FwdV@) and delayed signal values +-- (@DSignalV@). The flavors cannot meet in one group. +data GroupFlavor = SignalGroup | DSignalGroup deriving Eq + +valueMarkerFlavor :: SigMarker -> GroupFlavor +valueMarkerFlavor = \case + DSignalVMarker -> DSignalGroup + _ -> SignalGroup + data PortDescription a = Tuple [PortDescription a] | Vec SrcSpanAnnA [PortDescription a] | Ref a | RefMulticast a | Lazy SrcSpanAnnA (PortDescription a) - | FwdExpr (LHsExpr GhcPs) - | FwdPat (LPat GhcPs) + | FwdExpr SigMarker (LHsExpr GhcPs) + | FwdPat SigMarker (LPat GhcPs) + | SigTagExpr SigMarker (LHsExpr GhcPs) + -- ^ generated for value markers: a value-boundary bus expression, tagged + -- with @SigTag@/@FwdTag@ according to the marker + | SigTagPat SigMarker (LPat GhcPs) + -- ^ generated for value markers: a value-boundary bus pattern, tagged with + -- @SigTag@/@FwdTag@ according to the marker | PortType (LHsType GhcPs) (PortDescription a) | PortErr SrcSpanAnnA MsgDoc deriving (Foldable, Functor, Traversable) @@ -255,6 +302,8 @@ data CircuitState dec exp nm = CircuitState -- ^ type signatures in let bindings , _circuitLets :: [dec] -- ^ user defined let expression inside the circuit + , _circuitCompletes :: [dec] + -- ^ generated bindings that complete underscored ports , _circuitBinds :: [Binding exp nm] -- ^ @out <- circuit <- in@ statements , _circuitMasters :: PortDescription nm @@ -288,6 +337,7 @@ runCircuitM (CircuitM m) = do , _circuitSlaves = Tuple [] , _circuitTypes = [] , _circuitLets = [] + , _circuitCompletes = [] , _circuitBinds = [] , _circuitMasters = Tuple [] , _portVarTypes = emptyUniqMap @@ -331,9 +381,9 @@ noLoc :: e -> GenLocated (SrcAnn ann) e noLoc = noEpAnn . GHC.noLoc #endif -tupP :: p ~ GhcPs => [LPat p] -> LPat p -tupP [pat] = pat -tupP pats = noLoc $ TuplePat noExt pats GHC.Boxed +tupP :: p ~ GhcPs => SrcSpanAnnA -> [LPat p] -> LPat p +tupP _ [pat] = pat +tupP loc pats = L loc $ TuplePat noExt pats GHC.Boxed vecP :: (?nms :: ExternalNames) => SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs vecP srcLoc = \case @@ -650,7 +700,7 @@ bindSlave (L loc expr) = case expr of TuplePat _ lpat _ -> Tuple $ fmap bindSlave lpat ParPatP lpat -> bindSlave lpat ConPat _ (L _ (GHC.Unqual occ)) (PrefixCon [] [lpat]) - | OccName.occNameString occ `elem` fwdNames -> FwdPat lpat + | Just mk <- markerFromName occ -> FwdPat mk lpat -- empty list is done as the constructor ConPat _ (L _ rdr) _ | rdr == thName '[] -> Vec loc [] @@ -674,7 +724,7 @@ bindMaster (L loc expr) = case expr of | rdrName == thName '[] -> Vec loc [] -- XXX: vloc? | otherwise -> Ref (PortName loc (fromRdrName rdrName)) -- XXX: vloc? HsApp _xapp (L _ (HsVar _ (L _ (GHC.Unqual occ)))) sig - | OccName.occNameString occ `elem` fwdNames -> FwdExpr sig + | Just mk <- markerFromName occ -> FwdExpr mk sig ExplicitTuple _ tups _ -> let vals = fmap (\(Present _ e) -> e) tups in Tuple $ fmap bindMaster vals @@ -682,7 +732,7 @@ bindMaster (L loc expr) = case expr of Vec loc $ fmap bindMaster exprs -- XXX: Untested? HsProc _ _ (L _ (HsCmdTop _ (L _ (HsCmdArrApp _xapp (L _ (HsVar _ (L _ (GHC.Unqual occ)))) sig _ _)))) - | OccName.occNameString occ `elem` fwdNames -> FwdExpr sig + | Just mk <- markerFromName occ -> FwdExpr mk sig ExprWithTySig _ expr' ty -> PortType (hsSigWcType ty) (bindMaster expr') HsParP expr' -> bindMaster expr' @@ -773,10 +823,30 @@ checkCircuit = do data Direction = Fwd | Bwd deriving Show +-- | Best-effort source span of a port description: the combination of the +-- spans of everything in it. Generated tuple patterns and expressions take +-- this span so that type errors on a whole bus (e.g. a clock domain +-- mismatch between the ports of one bundle) point at the offending ports +-- rather than at the head of the @circuit@ block. +portDescLoc :: PortDescription PortName -> SrcSpan +portDescLoc = \case + Tuple ps -> foldr (combineSrcSpans . portDescLoc) noSrcSpan ps + Vec s _ -> locA s + Ref (PortName s _) -> locA s + RefMulticast (PortName s _) -> locA s + Lazy s _ -> locA s + FwdExpr _ (L s _) -> locA s + FwdPat _ (L s _) -> locA s + SigTagExpr _ (L s _) -> locA s + SigTagPat _ (L s _) -> locA s + PortType _ p -> portDescLoc p + PortErr s _ -> locA s + bindWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Direction -> PortDescription PortName -> LPat p bindWithSuffix dflags dir = \case - Tuple ps -> tildeP noSrcSpanA $ taggedBundleP $ tupP $ fmap (bindWithSuffix dflags dir) ps - Vec s ps -> taggedBundleP $ vecP s $ fmap (bindWithSuffix dflags dir) ps + p@(Tuple ps) -> let loc = noAnnSrcSpan (portDescLoc p) + in tildeP loc $ taggedBundleP loc $ tupP loc $ fmap (bindWithSuffix dflags dir) ps + Vec s ps -> taggedBundleP s $ vecP s $ fmap (bindWithSuffix dflags dir) ps Ref (PortName loc fs) -> varP loc (GHC.unpackFS fs <> "_" <> show dir) RefMulticast (PortName loc fs) -> case dir of Bwd -> L loc (WildPat noExtField) @@ -785,8 +855,10 @@ bindWithSuffix dflags dir = \case mkLongErrMsg dflags (locA loc) Outputable.alwaysQualify (Outputable.text "Unhandled bind") msgdoc Lazy loc p -> tildeP loc $ bindWithSuffix dflags dir p -- XXX: propagate location - FwdExpr (L _ _) -> nlWildPat - FwdPat lpat -> tagP lpat + FwdExpr _ (L _ _) -> nlWildPat + FwdPat mk lpat -> sigTagP mk lpat + SigTagExpr _ (L _ _) -> nlWildPat + SigTagPat mk lpat -> sigTagP mk lpat PortType ty p -> tagTypeP dir ty $ bindWithSuffix dflags dir p revDirec :: Direction -> Direction @@ -810,8 +882,9 @@ bindOutputs dflags direc slaves masters = noLoc $ conPatIn (noLoc (fwdBwdCon ?nm expWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> PortDescription PortName -> LHsExpr p expWithSuffix dir = \case - Tuple ps -> taggedBundleE $ tupE noSrcSpanA $ fmap (expWithSuffix dir) ps - Vec s ps -> taggedBundleE $ vecE s $ fmap (expWithSuffix dir) ps + p@(Tuple ps) -> let loc = noAnnSrcSpan (portDescLoc p) + in taggedBundleE loc $ tupE loc $ fmap (expWithSuffix dir) ps + Vec s ps -> taggedBundleE s $ vecE s $ fmap (expWithSuffix dir) ps Ref (PortName loc fs) -> varE loc (var $ GHC.unpackFS fs <> "_" <> show dir) RefMulticast (PortName loc fs) -> case dir of Bwd -> varE noSrcSpanA (trivialBwd ?nms) @@ -819,8 +892,12 @@ expWithSuffix dir = \case -- laziness only affects the pattern side Lazy _ p -> expWithSuffix dir p PortErr _ _ -> error "expWithSuffix PortErr!" - FwdExpr lexpr -> tagE lexpr - FwdPat (L l _) -> tagE $ varE l (trivialBwd ?nms) + FwdExpr mk lexpr -> sigTagE mk lexpr + FwdPat _ (L l _) -> tagE $ varE l (trivialBwd ?nms) + SigTagExpr mk lexpr -> sigTagE mk lexpr + -- the backwards channel of a signal bus is trivial, so a plain (untyped) + -- tag suffices; the forwards occurrence pins the bus type + SigTagPat _ (L l _) -> tagE $ varE l (trivialBwd ?nms) PortType ty p -> tagTypeE dir ty (expWithSuffix dir p) createInputs @@ -874,11 +951,11 @@ runCircuitFun loc = varE loc (runCircuitName ?nms) prefixCon :: [arg] -> HsConDetails tyarg arg rec prefixCon a = PrefixCon [] a -taggedBundleP :: (p ~ GhcPs, ?nms :: ExternalNames) => LPat p -> LPat p -taggedBundleP a = noLoc (conPatIn (noLoc (tagBundlePat ?nms)) (prefixCon [a])) +taggedBundleP :: (p ~ GhcPs, ?nms :: ExternalNames) => SrcSpanAnnA -> LPat p -> LPat p +taggedBundleP loc a = L loc (conPatIn (noLoc (tagBundlePat ?nms)) (prefixCon [a])) -taggedBundleE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p -taggedBundleE a = varE noSrcSpanA (tagBundlePat ?nms) `appE` a +taggedBundleE :: (p ~ GhcPs, ?nms :: ExternalNames) => SrcSpanAnnA -> LHsExpr p -> LHsExpr p +taggedBundleE loc a = varE loc (tagBundlePat ?nms) `appE` a tagP :: (p ~ GhcPs, ?nms :: ExternalNames) => LPat p -> LPat p tagP a = noLoc (conPatIn (noLoc (tagName ?nms)) (prefixCon [a])) @@ -886,6 +963,26 @@ tagP a = noLoc (conPatIn (noLoc (tagName ?nms)) (prefixCon [a])) tagE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p tagE a = varE noSrcSpanA (tagName ?nms) `appE` a +-- the SigTag wrappers take the location of what they wrap so that type +-- errors on the value boundary (e.g. marking a non-signal bus with @Signal@) +-- point at the marked pattern or expression +sigTagP :: (p ~ GhcPs, ?nms :: ExternalNames) => SigMarker -> LPat p -> LPat p +sigTagP mk a@(L l _) = L l (conPatIn (noLoc (markerTagName mk)) (prefixCon [a])) + +sigTagE :: (p ~ GhcPs, ?nms :: ExternalNames) => SigMarker -> LHsExpr p -> LHsExpr p +sigTagE mk a@(L l _) = varE l (markerTagName mk) `appE` a + +-- | The tag wrapped around a marked port: plain 'BusTag' for the generic +-- bus-level @Fwd@, the type-enforcing tags for everything else. +markerTagName :: (?nms :: ExternalNames) => SigMarker -> GHC.RdrName +markerTagName = \case + FwdMarker -> tagName ?nms + SignalMarker -> signalTagName ?nms + DSignalMarker -> dSignalTagName ?nms + SignalVMarker -> signalTagName ?nms + FwdVMarker -> fwdTagName ?nms + DSignalVMarker -> dSignalTagName ?nms + tagTypeCon :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsType GhcPs tagTypeCon = noLoc (HsTyVar noExt NotPromoted (noLoc (tagTName ?nms))) @@ -967,21 +1064,26 @@ tyEq a b = -- Final construction -------------------------------------------------- -circuitQQExpM +busCircuitQQExpM :: (p ~ GhcPs, ?nms :: ExternalNames) => CircuitM (LHsExpr p) -circuitQQExpM = do +busCircuitQQExpM = do checkCircuit dflags <- GHC.getDynFlags binds <- L.use circuitBinds lets <- L.use circuitLets + completes <- L.use circuitCompletes letTypes <- L.use circuitTypes slaves <- L.use circuitSlaves masters <- L.use circuitMasters - -- Construction of the circuit expression - let decs = lets <> map (noLoc . decFromBinding dflags) binds + -- Construction of the circuit expression. + -- Locate each generated binding at its circuit expression so that type + -- errors on a bus are reported on the offending statement rather than at + -- the end of the circuit block (see tests/fixtures/BusError.hs). + let decFromBinding' b@Binding{bCircuit = L cloc _} = L cloc (decFromBinding dflags b) + let decs = lets <> completes <> map decFromBinding' binds let pats = bindOutputs dflags Fwd masters slaves res = createInputs Bwd slaves masters @@ -997,6 +1099,316 @@ circuitQQExpM = do pure $ circuitConstructor noSrcSpanA `appE` lamE [pats] body +-- Value-level ports (SignalV/FwdV markers) ---------------------------- + +-- | The number of value-level (@SignalV@/@FwdV@-marked) ports in a port +-- description. +countValuePorts :: PortDescription PortName -> Int +countValuePorts p = + length [() | FwdPat mk _ <- L.universe p, isValueMarker mk] + + length [() | FwdExpr mk _ <- L.universe p, isValueMarker mk] + +-- | Replace each value-level ('Signal' / 'Fwd') pattern with a reference to a +-- generated signal bus variable (@prefix <> show i@), collecting the original +-- value-level patterns in order. +replaceFwdPats + :: String + -> PortDescription PortName + -> State (Int, [(SigMarker, LPat GhcPs)]) (PortDescription PortName) +replaceFwdPats prefix = L.transformM \case + FwdPat mk lpat@(L loc _) | isValueMarker mk -> do + (i, pats) <- get + put (i + 1, pats <> [(mk, lpat)]) + pure (SigTagPat mk (varP loc (prefix <> show i))) + p -> pure p + +-- | Replace each value-level ('Signal' / 'Fwd') expression with a reference +-- to a generated signal bus variable (@prefix <> show i@), collecting the +-- original value-level expressions in order. +replaceFwdExprs + :: String + -> PortDescription PortName + -> State (Int, [(SigMarker, LHsExpr GhcPs)]) (PortDescription PortName) +replaceFwdExprs prefix = L.transformM \case + FwdExpr mk lexpr@(L loc _) | isValueMarker mk -> do + (i, exprs) <- get + put (i + 1, exprs <> [(mk, lexpr)]) + pure (SigTagExpr mk (varE loc (var (prefix <> show i)))) + p -> pure p + +-- | The value-aware entry point for @circuit@ blocks. +-- +-- Value-level ports describe a circuit's logic over the values sampled +-- each clock cycle. The boundary between bus land and value land is marked +-- with @SignalV@ (or @FwdV@): @SignalV n <- ...@ binds @n@ to the per-cycle +-- value carried on that bus, and @... -< SignalV e@ injects the per-cycle +-- value @e@ back onto a bus. +-- +-- All the value-level bindings (the @let@s of the do block) are collected +-- into a single pure function, @circuitLogic@, whose arguments are the +-- @Signal@-bound values and whose results are the @Signal@-injected +-- expressions. It is lifted to the signal level with 'fmap', using +-- 'bundle' / 'unbundle' and a lazy let binding to tie feedback loops: +-- +-- @ +-- circuitLogic = \\(ins) -> let \ in (outs) +-- (outBuses) = unbundle (fmap circuitLogic (bundle (inBuses))) +-- @ +-- +-- The buses themselves are wired up exactly as for an ordinary @circuit@. +circuitQQExpM + :: (p ~ GhcPs, ?nms :: ExternalNames) + => CircuitM (LHsExpr p) +circuitQQExpM = do + slaves0 <- L.use circuitSlaves + masters0 <- L.use circuitMasters + binds0 <- L.use circuitBinds + + let boundaryCount = + sum (map countValuePorts (slaves0 : masters0 : concatMap (\b -> [bIn b, bOut b]) binds0)) + + -- Without any value-level (SignalV/FwdV) ports there is no boundary to + -- lift; generate plain bus plumbing. + if boundaryCount == 0 then busCircuitQQExpM else valueCircuitQQExpM + +valueCircuitQQExpM + :: (p ~ GhcPs, ?nms :: ExternalNames) + => CircuitM (LHsExpr p) +valueCircuitQQExpM = do + checkCircuit + + dflags <- GHC.getDynFlags + loc <- L.use circuitLoc + + -- read the ports after checkCircuit, which may have rewritten them + slaves0 <- L.use circuitSlaves + masters0 <- L.use circuitMasters + binds0 <- L.use circuitBinds + + let inPrefix = genLocName loc "valIn" <> "_" + outPrefix = genLocName loc "valOut" <> "_" + logicName = genLocName loc "circuitLogic" + + -- Value patterns become the arguments of circuitLogic (values sampled off + -- buses) ... + let inM = do + s <- replaceFwdPats inPrefix slaves0 + bs <- traverse (\b -> (\p -> b { bIn = p }) <$> replaceFwdPats inPrefix (bIn b)) binds0 + pure (s, bs) + ((slaves1, binds1), (numIns, inPats)) = runState inM (0, []) + + -- ... and value expressions become its results (values written to buses). + let outM = do + bs <- traverse (\b -> (\p -> b { bOut = p }) <$> replaceFwdExprs outPrefix (bOut b)) binds1 + m <- replaceFwdExprs outPrefix masters0 + pure (bs, m) + ((binds2, masters1), (numOuts, outExprs)) = runState outM (0, []) + + circuitSlaves .= slaves1 + circuitMasters .= masters1 + circuitBinds .= binds2 + + -- In a value circuit the do-block lets are value-level; they form the + -- bodies of the generated logic functions rather than ending up in the + -- outer (bus-level) let -- except for lets that don't touch any + -- value-level variable, which stay in the outer let (so e.g. a let-bound + -- sub-circuit can still be used with @-<@). + lets <- L.use circuitLets + completes <- L.use circuitCompletes + letTypes <- L.use circuitTypes + + -- see [value-components] + let valueNames = Set.fromList (concatMap (patVarNames . snd) inPats <> concatMap bindDefinedNames lets) + valueFvs :: SYB.Data a => a -> Set.Set String + valueFvs a = Set.intersection (freeVarNames a) valueNames + + items = + [ (ItemIn i, Set.fromList (patVarNames p)) | (i, (_, p)) <- zip [0 ..] inPats ] <> + [ (ItemOut k, valueFvs e) | (k, (_, e)) <- zip [0 ..] outExprs ] <> + [ (ItemLet j, Set.fromList (bindDefinedNames b) `Set.union` valueFvs b) + | (j, b) <- zip [0 ..] lets ] + + itemSeq = \case + ItemIn i -> i + ItemOut k -> numIns + k + ItemLet j -> numIns + numOuts + j + isBoundary = \case ItemLet{} -> False; _ -> True + + groups = sortOn (minimum . map itemSeq . fst) (groupComponents items) + (innerGroups, outerGroups) = partition (any isBoundary . fst) groups + + -- lets disconnected from the value boundary stay in the outer let + outerLets = [ lets !! j | (its, _) <- outerGroups, ItemLet j <- its ] + + -- assign user type signatures to the group that binds their name, + -- splitting multi-name signatures if necessary + nameComp = Map.fromList + [ (n, ci) | (ci, (_, ns)) <- zip [0 :: Int ..] innerGroups, n <- Set.toList ns ] + sigComp (L _ rdr) = case unqualName rdr of + [n] -> Map.lookup n nameComp + _ -> Nothing + splitSigs = concatMap + (\lsig@(L l s) -> case s of + TypeSig x ids ty -> + [ (c, L l (TypeSig x ids' ty)) + | (c, ids') <- Map.toList (Map.fromListWith (flip (<>)) [ (sigComp i, [i]) | i <- ids ]) ] + _ -> [(Nothing, lsig)]) + letTypes + sigsForComp ci = [ s | (Just ci', s) <- splitSigs, ci' == ci ] + outerSigs = [ s | (Nothing, s) <- splitSigs ] + + -- Each group is lifted with the bundle matching its markers' flavor; + -- plain (SignalV/FwdV) and delayed (DSignalV) values cannot meet in one + -- group, since neither bundle accepts both bus kinds. + flavors <- forM innerGroups \(its, _) -> do + let mks = [ (fst (inPats !! i), getLoc (snd (inPats !! i))) | ItemIn i <- its ] + <> [ (fst (outExprs !! k), getLoc (snd (outExprs !! k))) | ItemOut k <- its ] + dLocs = [ l | (mk, l) <- mks, valueMarkerFlavor mk == DSignalGroup ] + sLocs = [ l | (mk, l) <- mks, valueMarkerFlavor mk == SignalGroup ] + case (dLocs, sLocs) of + (dl : _, _ : _) -> do + errM (locA dl) $ + "This value group mixes DSignalV with SignalV/FwdV markers. " + <> "Delayed and undelayed values cannot meet in one logic group; " + <> "convert between Signal and DSignal explicitly at the bus level " + <> "instead." + pure DSignalGroup + (_ : _, []) -> pure DSignalGroup + _ -> pure SignalGroup + + -- One logic function and one lifted knot binding per group: + -- circuitLogic_cN = \(ins) -> let in (outs) + -- (outBuses) = unbundle (fmap circuitLogic_cN (bundle (inBuses))) + -- bundle/unbundle are only needed when there is more than one bus, and + -- with no inputs at all the logic is constant, so it is mapped over + -- @pure ()@. The generated bundle elements and knot patterns take the + -- source locations of the original markers, so clock domain (and + -- delay) mismatches are reported on the offending marker. Groups with + -- no outputs produce no value (their logic would be dead) and generate + -- nothing. + let mkComp ci flavor (its, _) = + let ins = sort [ i | ItemIn i <- its ] + outs = sort [ k | ItemOut k <- its ] + ls = sort [ j | ItemLet j <- its ] + (bundleNm, unbundleNm) = case flavor of + SignalGroup -> (thName 'bundle, thName 'unbundle) + DSignalGroup -> (thName 'DBundle.bundle, thName 'DBundle.unbundle) + logicNm = logicName <> "_c" <> show ci + -- A leading lazy unit keeps every real input out of 'bundle's + -- spine-forcing head slot ('bundle' lifts its first element with + -- 'fmap' / 'mapSignal#', which forces that element's spine), so + -- combinational feedback between value groups does not deadlock + -- simulation. + pureUnitE = varE noSrcSpanA (thName 'pure) `appE` tupE noSrcSpanA [] + -- Each value-input pattern is matched lazily (irrefutable), as the + -- bus-level plumbing already is. A strict value pattern (e.g. a + -- constructor pattern that destructures the sampled value at the + -- boundary) would force its input to produce ANY of the group's + -- outputs -- even outputs that don't use it -- which deadlocks when + -- that input depends, through the circuit, on such an output. + logicPat = case ins of + [] -> tupP noSrcSpanA [] + _ -> tupP noSrcSpanA (L noSrcSpanA (WildPat noExtField) : map (tildeP noSrcSpanA . snd . (inPats !!)) ins) + logicLam = lamE [logicPat] + (letE noSrcSpanA (sigsForComp ci) (map (lets !!) ls) + (tupE noSrcSpanA (map (snd . (outExprs !!)) outs))) + logicBind = L loc $ patBind (varP noSrcSpanA logicNm) logicLam + + inVars = map (\i -> let (L l _) = snd (inPats !! i) in varE l (var (inPrefix <> show i))) ins + outVarPs = map (\k -> let (L l _) = snd (outExprs !! k) in varP l (outPrefix <> show k)) outs + + bundled = case inVars of + [] -> pureUnitE + es -> varE noSrcSpanA bundleNm `appE` tupE noSrcSpanA (pureUnitE : es) + lifted = varE noSrcSpanA (thName 'fmap) `appE` varE noSrcSpanA (var logicNm) `appE` bundled + knotExpr = if length outs > 1 + then varE noSrcSpanA unbundleNm `appE` lifted + else lifted + outsLoc = noAnnSrcSpan (foldr (combineSrcSpans . getLocA) noSrcSpan outVarPs) + knotBind = L loc $ patBind (tupP outsLoc outVarPs) knotExpr + in if null outs then [] else [logicBind, knotBind] + + compDecs = concat (zipWith3 mkComp [0 ..] flavors innerGroups) + + -- The bus plumbing is generated exactly as in 'busCircuitQQExpM'. + let decFromBinding' b@Binding{bCircuit = L cloc _} = L cloc (decFromBinding dflags b) + let decs = compDecs <> outerLets <> completes <> map decFromBinding' binds2 + + let pats = bindOutputs dflags Fwd masters1 slaves1 + res = createInputs Bwd slaves1 masters1 + + body :: LHsExpr GhcPs + body = letE noSrcSpanA outerSigs decs res + + pure $ circuitConstructor noSrcSpanA `appE` lamE [pats] body + +-- [value-components] +-- The value-level bindings of a @circuit@ block are split into the +-- connected components of their shared-variable graph before lifting: an +-- input variable (Signal pattern), output expression (Signal expression) or +-- let binding belongs to the same group as anything it shares a value-level +-- variable with. Each group is lifted with its own fmap/bundle/unbundle, so +-- only buses whose values actually meet are bundled -- which is what allows +-- a single circuit block to span several clock domains: per-cycle values +-- may only meet if their buses are synchronous, and 'bundle' enforces +-- exactly that per group. Sharing a variable across domains is an +-- (unsynchronized) clock domain crossing and is rejected by the type +-- checker; crossing domains must be done with explicit bus-level +-- synchronizer circuits. +-- +-- The analysis is purely syntactic and conservative: free variables are +-- over-approximated by all unqualified variable occurrences (no scope +-- tracking), so shadowing can only ever merge groups that strictly wouldn't +-- need merging (a false same-domain constraint), never split things that +-- belong together. + +-- | An occurrence of the value boundary (or a let between boundaries) in a +-- @circuit@ block; the @Int@ indexes into the respective collection. +data ValueItem = ItemIn Int | ItemOut Int | ItemLet Int + +-- | Group items into connected components: items (transitively) sharing a +-- name end up in the same group. +groupComponents :: [(ValueItem, Set.Set String)] -> [([ValueItem], Set.Set String)] +groupComponents = foldl step [] + where + step groups (it, ns) = + let (touching, rest) = partition (\(_, gns) -> not (Set.disjoint ns gns)) groups + in (concatMap fst touching <> [it], Set.unions (ns : map snd touching)) : rest + +unqualName :: GHC.RdrName -> [String] +unqualName = \case + GHC.Unqual occ -> [OccName.occNameString occ] + _ -> [] + +-- | Variable names bound by a pattern (conservative, syntactic; as-pattern +-- names are not collected). +patVarNames :: LPat GhcPs -> [String] +patVarNames = SYB.everything (<>) (SYB.mkQ [] q) + where + q :: Pat GhcPs -> [String] + q = \case + VarPat _ (L _ rdr) -> unqualName rdr + _ -> [] + +-- | All unqualified variable occurrences: a conservative over-approximation +-- of the free variables (bound variables of nested lambdas/lets/cases are +-- included). +freeVarNames :: SYB.Data a => a -> Set.Set String +freeVarNames = Set.fromList . SYB.everything (<>) (SYB.mkQ [] q) + where + q :: HsExpr GhcPs -> [String] + q = \case + HsVar _ (L _ rdr) -> unqualName rdr + _ -> [] + +-- | The names a let binding defines. +bindDefinedNames :: LHsBind GhcPs -> [String] +bindDefinedNames (L _ b) = case b of + FunBind { fun_id = L _ rdr } -> unqualName rdr + PatBind { pat_lhs = lpat } -> patVarNames lpat + VarBind { var_id = rdr } -> unqualName rdr + _ -> [] + grr :: MonadIO m => OccName.NameSpace -> m () grr nm | nm == OccName.tcName = liftIO $ putStrLn "tcName" @@ -1016,7 +1428,7 @@ completeUnderscores = do addDef suffix = \case Ref (PortName loc (unpackFS -> name@('_':_))) -> do let bind = patBind (varP loc (name <> suffix)) (tagE $ varE loc (thName 'def)) - circuitLets <>= [L loc bind] + circuitCompletes <>= [L loc bind] _ -> pure () addBind :: Binding exp PortName -> CircuitM () @@ -1124,8 +1536,16 @@ showC a = show (typeOf a) <> " " <> show (Data.toConstr a) -- Names --------------------------------------------------------------- -fwdNames :: [String] -fwdNames = ["Fwd", "Signal"] +-- | Recognise the port marker keywords (see 'SigMarker'). +markerFromName :: OccName.OccName -> Maybe SigMarker +markerFromName occ = case OccName.occNameString occ of + "Signal" -> Just SignalMarker + "Fwd" -> Just FwdMarker + "DSignal" -> Just DSignalMarker + "SignalV" -> Just SignalVMarker + "FwdV" -> Just FwdVMarker + "DSignalV" -> Just DSignalVMarker + _ -> Nothing -- | Collection of names external to circuit-notation. data ExternalNames = ExternalNames @@ -1133,6 +1553,15 @@ data ExternalNames = ExternalNames , runCircuitName :: GHC.RdrName , tagBundlePat :: GHC.RdrName , tagName :: GHC.RdrName + , signalTagName :: GHC.RdrName + -- ^ a (pattern synonym) variant of 'tagName' whose type pins the bus to be + -- a signal; used for @Signal@ markers at the value boundary of @circuitV@ + -- blocks + , fwdTagName :: GHC.RdrName + -- ^ like 'signalTagName' but class-constrained, accepting any signal-like + -- bus; used for @FwdV@ markers at the value boundary of @circuit@ blocks + , dSignalTagName :: GHC.RdrName + -- ^ like 'signalTagName' for delayed signals; used for @DSignalV@ markers , tagTName :: GHC.RdrName , fwdBwdCon :: GHC.RdrName , fwdAndBwdTypes :: Direction -> GHC.RdrName @@ -1140,12 +1569,20 @@ data ExternalNames = ExternalNames , consPat :: GHC.RdrName } +-- | The names used by the plugin by default, referring to the @Circuit@ +-- module of this package. Custom plugins are encouraged to build their +-- names as a record update of this, so that newly added fields (which +-- happens when the notation grows new features) default to something +-- sensible. defExternalNames :: ExternalNames defExternalNames = ExternalNames { circuitCon = GHC.Unqual (OccName.mkDataOcc "TagCircuit") , runCircuitName = GHC.Unqual (OccName.mkVarOcc "runTagCircuit") , tagBundlePat = GHC.Unqual (OccName.mkDataOcc "BusTagBundle") , tagName = GHC.Unqual (OccName.mkDataOcc "BusTag") + , signalTagName = GHC.Unqual (OccName.mkDataOcc "SigTag") + , fwdTagName = GHC.Unqual (OccName.mkDataOcc "FwdTag") + , dSignalTagName = GHC.Unqual (OccName.mkDataOcc "DSigTag") , tagTName = GHC.Unqual (OccName.mkTcOcc "BusTag") , fwdBwdCon = GHC.Unqual (OccName.mkDataOcc ":->") , fwdAndBwdTypes = \case diff --git a/tests/error-location.hs b/tests/error-location.hs new file mode 100644 index 0000000..26c4671 --- /dev/null +++ b/tests/error-location.hs @@ -0,0 +1,140 @@ +-- | Regression tests for the source locations of error messages. +-- +-- When bus tagging (the @BusTag@ wrapping) was introduced, type errors on a +-- bus stopped pointing at the offending statement and instead pointed at the +-- end of the @circuit@ block, which made them very hard to act on. The same +-- concern applies to @circuitV@ blocks, where the value-level expressions and +-- lets are moved into a generated @circuitLogic@ function. +-- +-- Each fixture in 'fixtures' deliberately fails to compile, with the +-- offending statement tagged by a marker comment that appears on exactly one +-- line. The fixture is compiled with the plugin enabled and we assert that an +-- error is reported /on that line/ (and, optionally, that the output contains +-- an expected message). It uses the same plain @ghc@ + +-- package-environment-file mechanism that CI already uses to compile the +-- @Example@ module. +module Main (main) where + +import Control.Monad (forM, unless, when) +import Data.List (isInfixOf, isPrefixOf, nub, sort) +import Data.Maybe (mapMaybe) +import System.Directory (getTemporaryDirectory) +import System.Environment (lookupEnv) +import System.Exit (exitFailure) +import System.FilePath (()) +import System.Process (readProcessWithExitCode) +import Text.Read (readMaybe) + +data Fixture = Fixture + { fixturePath :: FilePath + -- ^ the file to compile, which must fail to compile + , fixtureMarker :: String + -- ^ marker comment on the line the error should be reported on; it must + -- appear on exactly one line of the fixture + , fixtureNeedle :: Maybe String + -- ^ optionally, a string the compiler output must contain + } + +fixtures :: [Fixture] +fixtures = + [ -- type error on a bus in an ordinary circuit + Fixture ("tests" "fixtures" "BusError.hs") "bus-error-marker" Nothing + -- type error on a value-level expression in a circuitV + , Fixture ("tests" "fixtures" "ValueExprError.hs") "value-expr-error-marker" Nothing + -- type error inside a value-level let in a circuitV + , Fixture ("tests" "fixtures" "ValueLetError.hs") "value-let-error-marker" Nothing + -- port error reported by the plugin itself in a circuitV + , Fixture ("tests" "fixtures" "ValuePortError.hs") "value-port-error-marker" + (Just "has no associated master") + -- a Signal marker on a bus that is not a signal (the marker is "too + -- shallow"); the SigTag the plugin generates should turn this into a + -- direct Vec-vs-Signal mismatch on the offending pattern + , Fixture ("tests" "fixtures" "ValueShapeError.hs") "value-shape-error-marker" Nothing + -- sharing a value-level variable across two clock domains; the merged + -- group's bundle demands one domain, so this must be a domain-mismatch + -- type error + , Fixture ("tests" "fixtures" "CrossDomainError.hs") "cross-domain-error-marker" + (Just "Couldn't match type") + -- sharing a value-level variable between two pipeline depths; the + -- merged group's delayed bundle demands one delay index + , Fixture ("tests" "fixtures" "CrossDelayError.hs") "cross-delay-error-marker" + (Just "Couldn't match type") + -- mixing plain and delayed value markers in one group is reported by + -- the plugin itself, at the offending marker + , Fixture ("tests" "fixtures" "MixedMarkerError.hs") "mixed-marker-error-marker" + (Just "mixes DSignalV with SignalV/FwdV") + ] + +main :: IO () +main = do + ghc <- maybe "ghc" id <$> lookupEnv "GHC" + results <- forM fixtures (checkFixture ghc) + unless (and results) exitFailure + +checkFixture :: String -> Fixture -> IO Bool +checkFixture ghc (Fixture fixture marker needle) = do + src <- readFile fixture + + -- Work out which line the deliberate error is on by finding the marker. + let markedLines = + [ n | (n, l) <- zip [1 :: Int ..] (lines src), marker `isInfixOf` l ] + expectedLine <- case markedLines of + [n] -> pure n + _ -> die $ "expected exactly one line containing " <> show marker + <> " in " <> fixture <> ", found lines " <> show markedLines + + -- Compile the fixture and collect the reported error lines. + tmp <- getTemporaryDirectory + let args = + [ "-outputdir", tmp "circuit-notation-error-test" + , "-itests/fixtures" + , fixture + ] + (_code, out, err) <- readProcessWithExitCode ghc args "" + let output = out <> err + errLines = sort . nub $ errorLineNumbers fixture output + + putStrLn $ fixture <> ":" + putStrLn $ " ghc reported errors on lines: " <> show errLines + putStrLn $ " expected an error on line: " <> show expectedLine + + when (null errLines) $ + die $ "expected the fixture to fail to compile, but ghc reported no\n\ + \error locations. Full output:\n" <> output + + unless (expectedLine `elem` errLines) $ + die $ "the error was not reported on the offending line (" + <> show expectedLine <> ").\n" + <> "Instead it was reported on lines " <> show errLines + <> " -- this is the regression where errors point at\n" + <> "the end of the circuit rather than the actual mistake.\n\n" + <> "Full ghc output:\n" <> output + + case needle of + Just msg | not (msg `isInfixOf` output) -> + die $ "expected the compiler output to mention " <> show msg + <> ".\n\nFull ghc output:\n" <> output + _ -> pure () + + putStrLn " OK: error points at the offending statement." + pure True + +-- | Extract the line numbers from GHC error messages that refer to the fixture, +-- e.g. a line @tests/fixtures/BusError.hs:30:8: error: ...@ yields @30@. +errorLineNumbers :: FilePath -> String -> [Int] +errorLineNumbers fixture = mapMaybe parseLine . lines + where + parseLine l = do + let l' = dropWhile (== ' ') l + rest <- stripFixturePrefix l' + let lineStr = takeWhile (/= ':') rest + readMaybe lineStr + + stripFixturePrefix l + | (fixture <> ":") `isPrefixOf` l = Just (drop (length fixture + 1) l) + | otherwise = Nothing + +die :: String -> IO a +die msg = do + putStrLn ("error-location test failed: " <> msg) + exitFailure diff --git a/tests/fixtures/BusError.hs b/tests/fixtures/BusError.hs new file mode 100644 index 0000000..5b743b8 --- /dev/null +++ b/tests/fixtures/BusError.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture that deliberately contains a type error on a bus, used by the +-- error-location test. The error is on the statement tagged with the marker +-- comment below: @boolC@ forces its input to be a +-- @Signal dom Bool@, but the bus @b@ carries a @Signal dom Int@. +-- +-- Crucially the erroring statement is /not/ the last statement of the circuit. +-- Before bus tagging gained source locations, GHC blamed the final statement +-- of the circuit (the @idC -< e@ line) instead of the actual mismatch, which +-- made the error very hard to track down. The test asserts that GHC points at +-- the tagged line. +module BusError where + +import Circuit +import Clash.Prelude + +boolC :: Circuit (Signal dom Bool) (Signal dom Bool) +boolC = idC + +busError :: Circuit (Signal dom Int) (Signal dom Int) +busError = circuit $ \a -> do + b <- idC -< a + c <- boolC -< b -- bus-error-marker + d <- idC -< c + e <- idC -< d + idC -< e diff --git a/tests/fixtures/CrossDelayError.hs b/tests/fixtures/CrossDelayError.hs new file mode 100644 index 0000000..a7bd611 --- /dev/null +++ b/tests/fixtures/CrossDelayError.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture sharing a value-level variable between two 'DSignal' buses at +-- /different/ pipeline depths: @a + b@ mixes a delay-0 and a delay-1 value. +-- The shared variables put both buses in the same logic group, whose +-- delayed bundle demands a single delay index, so GHC reports a +-- @0@-vs-@1@ mismatch. Like the cross-domain case, the blame lands on the +-- head of the circuit. +module CrossDelayError where + +import Circuit +import Clash.Prelude + +crossDelayError :: Circuit (DSignal dom 0 Int, DSignal dom 1 Int) (DSignal dom 0 Int) +crossDelayError = circuit \(DSignalV a, DSignalV b) -> do -- cross-delay-error-marker + idC -< DSignalV (a + b) diff --git a/tests/fixtures/CrossDomainError.hs b/tests/fixtures/CrossDomainError.hs new file mode 100644 index 0000000..f28d8d0 --- /dev/null +++ b/tests/fixtures/CrossDomainError.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture sharing a value-level variable across two clock domains in a +-- @circuit@ block: @acc + a + b@ mixes values sampled from a @domA@ bus and +-- a @domB@ bus, which is an (unsynchronized) clock domain crossing. The +-- shared variables put both buses in the same logic group, whose @bundle@ +-- demands a single domain, so GHC reports @Couldn't match type domA with +-- domB@. The generated slave pattern takes the span of its ports, so the +-- blame lands on the lambda pattern introducing @a@ and @b@ — which is on +-- a different line than the @circuit@ keyword here, to pin that down. +module CrossDomainError where + +import Circuit +import Clash.Prelude +import Clash.Signal.Internal (Signal ((:-))) + +registerC :: a -> Circuit (Signal dom a) (Signal dom a) +registerC a = Circuit $ \(s :-> ()) -> (() :-> (a :- s)) + +crossDomainError :: Circuit (Signal domA Int, Signal domB Int) (Signal domA Int) +crossDomainError = circuit + \(SignalV a, SignalV b) -> do -- cross-domain-error-marker + SignalV acc <- registerC 0 -< SignalV (acc + a + b) + idC -< SignalV acc diff --git a/tests/fixtures/MixedMarkerError.hs b/tests/fixtures/MixedMarkerError.hs new file mode 100644 index 0000000..8153179 --- /dev/null +++ b/tests/fixtures/MixedMarkerError.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture mixing plain (@SignalV@) and delayed (@DSignalV@) value +-- markers in one logic group: neither the plain nor the delayed bundle +-- accepts both bus kinds, so the plugin itself reports the conflict -- +-- pointing at the offending @DSignalV@ marker. +module MixedMarkerError where + +import Circuit +import Clash.Prelude + +mixedMarkerError :: Circuit (Signal dom Int, DSignal dom 0 Int) (Signal dom Int) +mixedMarkerError = circuit + \( SignalV a + , DSignalV b -- mixed-marker-error-marker + ) -> do + idC -< SignalV (a + b) diff --git a/tests/fixtures/ValueExprError.hs b/tests/fixtures/ValueExprError.hs new file mode 100644 index 0000000..eb8f5ed --- /dev/null +++ b/tests/fixtures/ValueExprError.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture with a deliberate type error on a /value-level/ expression in a +-- @circuit@ block: @a@ is an 'Int' (sampled off the input bus) but is used +-- with @(&&)@. The erroring statement is not the last statement of the +-- circuit; the error-location test asserts GHC points at the tagged line and +-- not at the end of the block (where the generated @circuitLogic@ and +-- knot-tying bindings live). +module ValueExprError where + +import Circuit +import Clash.Prelude +import Clash.Signal.Internal (Signal ((:-))) + +registerC :: a -> Circuit (Signal dom a) (Signal dom a) +registerC a = Circuit $ \(s :-> ()) -> (() :-> (a :- s)) + +valueExprError :: Circuit (Signal dom Int) (Signal dom Int) +valueExprError = circuit \(SignalV a) -> do + SignalV b <- registerC 0 -< SignalV (a && True) -- value-expr-error-marker + idC -< SignalV (b + a) diff --git a/tests/fixtures/ValueLetError.hs b/tests/fixtures/ValueLetError.hs new file mode 100644 index 0000000..d58a986 --- /dev/null +++ b/tests/fixtures/ValueLetError.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture with a deliberate type error inside a /value-level let/ of a +-- @circuit@ block: @a@ is an 'Int' (sampled off the input bus) but is +-- passed to 'not'. The let bindings move into the generated @circuitLogic@ +-- function; this asserts they keep their source locations when they do. +module ValueLetError where + +import Circuit +import Clash.Prelude + +valueLetError :: Circuit (Signal dom Int) (Signal dom Int) +valueLetError = circuit \(SignalV a) -> do + let b = not a -- value-let-error-marker + idC -< SignalV (a + (if b then 1 else 0)) diff --git a/tests/fixtures/ValuePortError.hs b/tests/fixtures/ValuePortError.hs new file mode 100644 index 0000000..cf862b7 --- /dev/null +++ b/tests/fixtures/ValuePortError.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture with a plugin-level port error in a @circuit@ block: the bus +-- @b@ is bound but never used, so the plugin itself (not GHC's type checker) +-- reports \"Slave port b has no associated master\" -- pointing at the +-- binding. +module ValuePortError where + +import Circuit +import Clash.Prelude + +valuePortError :: Circuit (Signal dom Int) (Signal dom Int) +valuePortError = circuit \(SignalV a) -> do + b <- idC -< SignalV (a + 1) -- value-port-error-marker + idC -< SignalV (a * 2) diff --git a/tests/fixtures/ValueShapeError.hs b/tests/fixtures/ValueShapeError.hs new file mode 100644 index 0000000..b7cb956 --- /dev/null +++ b/tests/fixtures/ValueShapeError.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS -fplugin=CircuitNotation #-} + +-- | A fixture marking a non-signal bus with @Signal@ in a @circuit@ block: +-- @vecC@ produces a @Vec@ of signals, so the @SignalV v@ pattern is \"too +-- shallow\" (the value boundary must sit exactly at a 'Signal'). The +-- generated @SigTag@ pins the bus type to a signal, so GHC reports a clear +-- @Vec ... /~ SignalV ...@ mismatch; this asserts it points at the offending +-- statement. +module ValueShapeError where + +import Circuit +import Clash.Prelude + +vecC :: Circuit (Signal dom Int) (Vec 2 (Signal dom Int)) +vecC = Circuit $ \(s :-> _) -> (() :-> (s :> s :> Nil)) + +valueShapeError :: Circuit (Signal dom Int) (Signal dom Int) +valueShapeError = circuit \(SignalV a) -> do + SignalV v <- vecC -< SignalV (a + 1) -- value-shape-error-marker + idC -< SignalV (a + 1) diff --git a/tests/unittests.hs b/tests/unittests.hs index 8262ed6..3d84ae1 100644 --- a/tests/unittests.hs +++ b/tests/unittests.hs @@ -2,10 +2,123 @@ -- wrong type or name, GHC would refuse to compile this file. {-# OPTIONS -fplugin=CircuitNotation #-} +{-# LANGUAGE DataKinds #-} + module Main where -import Circuit -import Example +import Control.Monad (unless) +import System.Exit (exitFailure) + +import Clash.Prelude (DSignal, NFDataX, Signal, System, + Vec ((:>), Nil), fromList, fromSignal, + sampleN, toSignal) + +import Circuit (Circuit) +import Example () +import ValueCircuits + +-- eta-expanded because Clash's sampleN takes a @HiddenClockResetEnable dom =>@ +-- argument, which only subsumes under DeepSubsumption +sample5 :: NFDataX a => Signal System a -> [a] +sample5 s = sampleN 5 s + +dsig :: NFDataX a => [a] -> DSignal System 0 a +dsig = fromSignal . fromList + +check :: (Eq a, Show a) => String -> a -> a -> IO Bool +check name actual expected + | actual == expected = pure True + | otherwise = do + putStrLn $ name <> ": expected " <> show expected <> " but got " <> show actual + pure False main :: IO () -main = pure () +main = do + let (fanA, fanB) = simulateC fanOutC (fromList [0 ..]) + (splitA, splitB) = simulateC splitC (fromList [(i, even i) | i <- [0 ..]]) + (mixA, mixB) = simulateC mixedC (fromList [0 ..], fromList [5 ..]) + (mcA, mcB) = simulateC multicastC (fromList [0 ..]) + + results <- sequence + -- basic shapes + [ check "plusOne" (sample5 (simulateC plusOne (fromList [0 ..]))) [1, 2, 3, 4, 5] + , check "plusOneBare" (sample5 (simulateC plusOneBare (fromList [0 ..]))) [1, 2, 3, 4, 5] + , check "vecSampleC" (sample5 (simulateC vecSampleC (fromList [1 ..] :> fromList [10, 20 ..] :> Nil))) + [11, 22, 33, 44, 55] + , check "vecEmitC" (fmap sample5 (simulateC vecEmitC (fromList [0 ..]))) + ([0, 1, 2, 3, 4] :> [1, 2, 3, 4, 5] :> Nil) + , check "tupleSampleC" + (sample5 (simulateC tupleSampleC + ( fromList [1 ..] + , fromList [10, 20 ..] :> fromList [100, 200 ..] :> Nil + , fromList [1000, 2000 ..] + , fromList [10000, 20000 ..] ))) + [11111, 22222, 33333, 44444, 55555] + , check "mixedMarkersC" + (sample5 (simulateC mixedMarkersC (fromList [100, 200 ..], fromList [1 ..] :> fromList [10, 20 ..] :> Nil))) + [111, 222, 333, 444, 555] + , check "vstreamC" (sample5 (simulateC vstreamC (fromList (fmap Just [0 ..])))) + [Just 1, Just 2, Just 3, Just 4, Just 5] + , let (mlV, mlA) = simulateC mixedLevelsC (fromList [1 ..] :> fromList [10, 20 ..] :> Nil, fromList [0 ..]) + in check "mixedLevelsC" (fmap sample5 mlV, sample5 mlA) + ([10, 20, 30, 40, 50] :> [1, 2, 3, 4, 5] :> Nil, [1, 2, 3, 4, 5]) + + -- delayed signals + , check "dplusOne" (sample5 (toSignal (simulateC dplusOne (dsig [0 ..])))) [1, 2, 3, 4, 5] + , check "daddC" (sample5 (toSignal (simulateC daddC (dsig [1 ..], dsig [10, 20 ..])))) + [11, 22, 33, 44, 55] + , check "dpipeC" (sample5 (toSignal (simulateC dpipeC (dsig [1 ..])))) [0, 4, 6, 8, 10] + , check "dmapC" (sample5 (toSignal (simulateC dmapC (dsig [0 ..])))) [1, 2, 3, 4, 5] + , check "plusOneFwd" (sample5 (simulateC plusOneFwd (fromList [0 ..]))) [1, 2, 3, 4, 5] + , check "alwaysFive" (sample5 (simulateC alwaysFive ())) [5, 5, 5, 5, 5] + , check "addC" (sample5 (simulateC addC (fromList [1 ..], fromList [10, 20 ..]))) + [11, 22, 33, 44, 55] + , check "fanOutC" (sample5 fanA, sample5 fanB) + ([1, 2, 3, 4, 5], [0, 2, 4, 6, 8]) + , check "splitC" (sample5 splitA, sample5 splitB) + ([0, 1, 2, 3, 4], [True, False, True, False, True]) + , check "joinC" (sample5 (simulateC joinC (fromList [1 ..], fromList [even i | i <- [0 :: Int ..]]))) + [(1, True), (2, False), (3, True), (4, False), (5, True)] + , check "nestedTupleC" + (sample5 (simulateC nestedTupleC ((fromList [1 ..], fromList [10, 20 ..]), pure 2))) + [21, 42, 63, 84, 105] + , check "vecInC" (sample5 (simulateC vecInC (fromList [10, 20 ..] :> fromList [1 ..] :> Nil))) + [9, 18, 27, 36, 45] + , check "vecOutC" (fmap sample5 (simulateC vecOutC (fromList [0 ..]))) + ([1, 2, 3, 4, 5] :> [-1, 0, 1, 2, 3] :> Nil) + , check "annotatedC" (sample5 (simulateC annotatedC (fromList [0 ..]))) [1, 2, 3, 4, 5] + + -- feedback + , check "counter" (sample5 (simulateC counter ())) [0, 1, 2, 3, 4] + , check "accum" (sample5 (simulateC accum (fromList [1 ..]))) [1, 3, 6, 10, 15] + , check "counter3" (sample5 (simulateC counter3 ())) [10, 12, 14, 16, 18] + , check "counter3Expanded" (sample5 (simulateC counter3Expanded ())) [10, 12, 14, 16, 18] + , check "fibC" (sample5 (simulateC fibC ())) [0, 1, 1, 2, 3] + , check "shift3" (sample5 (simulateC shift3 (fromList [1 ..]))) [0, 0, 0, 1, 2] + , check "rotate3" (sample5 (simulateC rotate3 (pure 1))) [6, 7, 8, 9, 10] + + -- mixing value land and bus land + , check "mixedC" (sample5 mixA, sample5 mixB) ([1, 2, 3, 4, 5], [5, 6, 7, 8, 9]) + , check "multicastC" (sample5 mcA, sample5 mcB) ([1, 2, 3, 4, 5], [1, 2, 3, 4, 5]) + , check "passthrough" (sample5 (simulateC passthrough (fromList [3 ..]))) [3, 4, 5, 6, 7] + + -- multiple clock domains (instantiated at the same domain here; the + -- different-domain property is the fact that the signatures compile) + , let (dcA, dcB) = simulateC + (dualCounter :: Circuit (Signal System Bool, Signal System Bool) (Signal System Int, Signal System Int)) + (fromList (cycle [True, False]), pure True) + in check "dualCounter" (sample5 dcA, sample5 dcB) ([0, 1, 1, 2, 2], [0, 1, 2, 3, 4]) + , let (daA, daB) = simulateC + (dualAccum :: Circuit (Signal System Int, Signal System Int) (Signal System Int, Signal System Int)) + (fromList [1 ..], fromList [10, 20 ..]) + in check "dualAccum" (sample5 daA, sample5 daB) ([0, 1, 3, 6, 10], [0, 10, 30, 60, 100]) + , check "busLevelLet" (sample5 (simulateC busLevelLet (fromList [0 ..]))) [4, 6, 8, 10, 12] + + -- nesting + , check "nestedSInCircuit" (sample5 (simulateC nestedSInCircuit (fromList [0 ..]))) [0, 2, 4, 6, 8] + , check "nestedCircuitInS" (sample5 (simulateC nestedCircuitInS (fromList [0 ..]))) [3, 6, 9, 12, 15] + , check "nestedSInS" (sample5 (simulateC nestedSInS (fromList [0 ..]))) [2, 4, 6, 8, 10] + ] + + putStrLn $ "passed " <> show (length (filter id results)) <> "/" <> show (length results) + unless (and results) exitFailure