diff --git a/cabal.project b/cabal.project index 84dac24c..07bb0f6f 100644 --- a/cabal.project +++ b/cabal.project @@ -13,4 +13,14 @@ package clash-prelude source-repository-package type: git location: https://github.com/cchalmers/circuit-notation.git - tag: 618e37578e699df235f2e7150108b6401731919b \ No newline at end of file + tag: 565d4811cff6a597ee577dabd81b460e941fcb14 + +package clash-protocols + -- Reduces compile times by ~20% + ghc-options: +RTS -qn4 -A128M -RTS -j4 + + -- Workaround for Haddock/CPP #if issues https://github.com/haskell/haddock/issues/1382 + haddock-options: --optghc="-optP -P" + + -- Don't pollute docs with large tuple instances + haddock-options: --optghc=-DHADDOCK_ONLY diff --git a/clash-protocols.cabal b/clash-protocols.cabal index a4bd703a..120a7b20 100644 --- a/clash-protocols.cabal +++ b/clash-protocols.cabal @@ -25,6 +25,14 @@ flag ci Manual: True Default: False +flag large-tuples + description: + Generate instances for classes such as `Units` and `TaggedBundle` for tuples + up to and including 62 elements - the GHC imposed maximum. Note that this + greatly increases compile times for `clash-protocols`. + default: False + manual: True + common common-options default-extensions: BangPatterns @@ -122,6 +130,10 @@ custom-setup library import: common-options hs-source-dirs: src + + if flag(large-tuples) + CPP-Options: -DLARGE_TUPLES + build-depends: -- inline-circuit-notation circuit-notation @@ -131,10 +143,11 @@ library , ghc >= 8.7 , hashable , hedgehog >= 1.0.2 + , mtl , pretty-show , strict-tuple - , mtl - , hashable + , tagged + , template-haskell -- To be removed; we need 'Test.Tasty.Hedgehog.Extra' to fix upstream issues , tasty >= 1.2 && < 1.5 @@ -160,11 +173,16 @@ library Protocols.Wishbone.Standard Protocols.Wishbone.Standard.Hedgehog + Protocols.Cpp Protocols.Df Protocols.DfConv Protocols.Hedgehog Protocols.Hedgehog.Internal Protocols.Internal + Protocols.Internal.TaggedBundle + Protocols.Internal.TaggedBundle.TH + Protocols.Internal.Units + Protocols.Internal.Units.TH Protocols.Plugin diff --git a/src/Protocols.hs b/src/Protocols.hs index 672f46b3..4a0f8e05 100644 --- a/src/Protocols.hs +++ b/src/Protocols.hs @@ -55,8 +55,13 @@ module Protocols -- * Circuit notation plugin , circuit, (-<) + , module Protocols.Internal.Units + , module Protocols.Internal.TaggedBundle ) where import Data.Default (def) import Protocols.Internal import Protocols.Df (Df) + +import Protocols.Internal.Units +import Protocols.Internal.TaggedBundle diff --git a/src/Protocols/Hedgehog/Internal.hs b/src/Protocols/Hedgehog/Internal.hs index 486bcfb5..2344d529 100644 --- a/src/Protocols/Hedgehog/Internal.hs +++ b/src/Protocols/Hedgehog/Internal.hs @@ -1,10 +1,13 @@ {-| Internals for "Protocols.Hedgehog". -} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-# OPTIONS_HADDOCK hide #-} module Protocols.Hedgehog.Internal where diff --git a/src/Protocols/Internal.hs b/src/Protocols/Internal.hs index bb68b996..7d07085c 100644 --- a/src/Protocols/Internal.hs +++ b/src/Protocols/Internal.hs @@ -9,6 +9,8 @@ Internal module to prevent hs-boot files (breaks Haddock) {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- NFDataX and ShowX for Identity and Proxy +{-# OPTIONS_HADDOCK hide #-} + module Protocols.Internal where import Control.DeepSeq (NFData) diff --git a/src/Protocols/Internal/TaggedBundle.hs b/src/Protocols/Internal/TaggedBundle.hs new file mode 100644 index 00000000..e4b6d359 --- /dev/null +++ b/src/Protocols/Internal/TaggedBundle.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- For debugging TH: +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Protocols.Internal.TaggedBundle where + +import Clash.Explicit.Prelude + +import Protocols.Internal.TaggedBundle.TH (taggedBundleTupleInstances) +import Protocols.Cpp (maxTupleSize) + +import Data.Tagged + +-- | A bundle class that retains an attached phantom type @t@. I.e., a crossing +-- between "Tagged" and "Bundle". +class TaggedBundle t a where + type TaggedUnbundled t a = res | res -> t a + taggedBundle :: TaggedUnbundled t a -> Tagged t a + taggedUnbundle :: Tagged t a -> TaggedUnbundled t a + +instance TaggedBundle () () where + type TaggedUnbundled () () = () + taggedBundle = Tagged + taggedUnbundle = unTagged + +instance TaggedBundle (Vec n t) (Vec n a) where + type TaggedUnbundled (Vec n t) (Vec n a) = Vec n (Tagged t a) + taggedBundle = Tagged . fmap unTagged + taggedUnbundle = fmap Tagged . unTagged + +-- | A convenience pattern that bundles and unbundles. Can be used as an alternative +-- to using @ViewPatterns@. I.e., the following: +-- +-- > myFunction (taggedUnbundle -> ..) +-- +-- can be written as: +-- +-- > myFunction (TaggedBundle ..) +-- +-- Is mostly used by "Protocols.Plugin". +pattern TaggedBundle :: TaggedBundle t a => TaggedUnbundled t a -> Tagged t a +pattern TaggedBundle a <- (taggedUnbundle -> a) where + TaggedBundle a = taggedBundle a +{-# COMPLETE TaggedBundle #-} + +-- XXX: The following comment trick does not seem to work for TaggedBundle, but +-- it does for Units. Weird! + +-- | __NB__: The documentation only shows instances up to /3/-tuples. By +-- default, instances up to and including /12/-tuples will exist. If the flag +-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The +-- GHC imposed limit is either 62 or 64 depending on the GHC version. +taggedBundleTupleInstances maxTupleSize diff --git a/src/Protocols/Internal/TaggedBundle/TH.hs b/src/Protocols/Internal/TaggedBundle/TH.hs new file mode 100644 index 00000000..fa004412 --- /dev/null +++ b/src/Protocols/Internal/TaggedBundle/TH.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Protocols.Internal.TaggedBundle.TH where + +import Data.Tagged +import Language.Haskell.TH + +appTs :: Q Type -> [Q Type] -> Q Type +appTs = foldl appT + +tupT :: [Q Type] -> Q Type +tupT tyArgs = tupleT (length tyArgs) `appTs` tyArgs + +taggedBundleTupleInstances :: Int -> Q [Dec] +taggedBundleTupleInstances n = mapM taggedBundleTupleInstance [2..n] + +taggedBundleTupleInstance :: Int -> Q Dec +taggedBundleTupleInstance n = + instanceD + -- No superclasses + (pure []) + + -- Head + ( taggedBundleCon + `appT` (tupleT n `appTs` tagTyVars) + `appT` (tupleT n `appTs` tyVars) ) + + -- Implementation + [ tySynInstD (tySynEqn Nothing aTypeLhs aTypeRhs) + , funD taggedBundleFunName [clause [bundlePat] (normalB bundleImpl) []] + , funD taggedUnbundleFunName [clause [unbundlePat] (normalB unbundleImpl) []] + ] + + where + -- associated type + taggedUnbundledCon = conT (mkName "TaggedUnbundled") + taggedBundleCon = conT (mkName "TaggedBundle") + aTypeLhs = taggedUnbundledCon `appT` tupT tagTyVars `appT` tupT tyVars + aTypeRhs = tupT (zipWith mkTaggedTy tagTyVars tyVars) + mkTaggedTy ta a = conT ''Tagged `appT` ta `appT` a + + -- bundle + taggedBundleFunName = mkName "taggedBundle" + bundlePat = tupP (map (conP 'Tagged . pure . varP) varNames) + bundleImpl = conE 'Tagged `appE` tupE vars + + -- unbundle + taggedUnbundleFunName = mkName "taggedUnbundle" + unbundlePat = conP 'Tagged [tupP (map varP varNames)] + unbundleImpl = tupE [conE 'Tagged `appE` v | v <- vars] + + -- shared + tagTyVars = map (varT . mkName . ('t':) . show) [1..n] + tyVars = map varT varNames + vars = map varE varNames + varNames = map (mkName . ('a':) . show) [1..n] diff --git a/src/Protocols/Internal/Units.hs b/src/Protocols/Internal/Units.hs new file mode 100644 index 00000000..9a4ea2a3 --- /dev/null +++ b/src/Protocols/Internal/Units.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- For debugging TH: +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Protocols.Internal.Units where + +import Clash.Explicit.Prelude + +import Protocols.Internal.Units.TH (unitsTupleInstances) +import Protocols.Cpp (maxTupleSize) + +-- | Utilities for zero-width types. Is used by "Protocols.Plugin" to drive \"trivial\" +-- backwards channels. +class Units a where + -- | Only inhabitant of type @a@. + units :: a + +instance Units () where + units = () + +instance Units (Signed 0) where + units = 0 + +instance Units (Unsigned 0) where + units = 0 + +instance Units (BitVector 0) where + units = 0 + +instance Units (Index 0) where + units = 0 + +instance Units (Index 1) where + units = 0 + +instance (Units a) => Units (Signal dom a) where + units = pure units + +instance (Units a, KnownNat n) => Units (Vec n a) where + units = repeat units + +-- | __NB__: The documentation only shows instances up to /3/-tuples. By +-- default, instances up to and including /12/-tuples will exist. If the flag +-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The +-- GHC imposed limit is either 62 or 64 depending on the GHC version. +unitsTupleInstances maxTupleSize diff --git a/src/Protocols/Internal/Units/TH.hs b/src/Protocols/Internal/Units/TH.hs new file mode 100644 index 00000000..6668712b --- /dev/null +++ b/src/Protocols/Internal/Units/TH.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Protocols.Internal.Units.TH where + +import Language.Haskell.TH + +appTs :: Q Type -> [Q Type] -> Q Type +appTs = foldl appT + +unitsTupleInstances :: Int -> Q [Dec] +unitsTupleInstances n = mapM unitsTupleInstance [2..n] + +unitsTupleInstance :: Int -> Q Dec +unitsTupleInstance n = + instanceD + (mapM (\v -> unitsConT `appT` v) tyVars) -- context + (unitsConT `appT` (tupleT n `appTs` tyVars)) -- head + [funD unitsFunName [clause [] (normalB (tupE [unitsFun | _ <- tyVars])) []]] -- impl + + where + unitsFun = varE unitsFunName + unitsFunName = mkName "units" + unitsConT = conT (mkName "Units") + tyVars = map (varT . mkName . ('a':) . show) [1..n] diff --git a/src/Protocols/Plugin.hs b/src/Protocols/Plugin.hs index 3204048e..15f009eb 100644 --- a/src/Protocols/Plugin.hs +++ b/src/Protocols/Plugin.hs @@ -2,10 +2,15 @@ A GHC source plugin providing a DSL for writing Circuit components. Credits to @circuit-notation@ at . -} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} -module Protocols.Plugin where +module Protocols.Plugin + ( plugin + , circuit + , (-<) + ) where -- base import Prelude @@ -16,6 +21,9 @@ import Protocols -- circuit-notation import qualified CircuitNotation as CN +-- tagged +import Data.Tagged + -- ghc #if __GLASGOW_HASKELL__ >= 900 import qualified GHC.Plugins as GHC @@ -24,14 +32,35 @@ import qualified GhcPlugins as GHC #endif -- | Type inference helper used by circuit-notation plugin -type CircuitT a b = (Fwd a, Bwd b) -> (Bwd a, Fwd b) +type TaggedCircuitT a b = + (Tagged a (Fwd a), Tagged b (Bwd b)) -> + (Tagged a (Bwd a), Tagged b (Fwd b)) + +mkTagCircuit :: TaggedCircuitT a b -> Circuit a b +mkTagCircuit f = Circuit $ \ (aFwd, bBwd) -> let + (Tagged aBwd, Tagged bFwd) = f (Tagged aFwd, Tagged bBwd) + in (aBwd, bFwd) + +runTagCircuit :: Circuit a b -> TaggedCircuitT a b +runTagCircuit (Circuit c) (aFwd, bBwd) = let + (aBwd, bFwd) = c (unTagged aFwd, unTagged bBwd) + in (Tagged aBwd, Tagged bFwd) + +pattern TaggedCircuit :: TaggedCircuitT a b -> Circuit a b +pattern TaggedCircuit f <- (runTagCircuit -> f) where + TaggedCircuit f = mkTagCircuit f --- | 'circuit-notation' plugin repurposed for 'Protocols.protocols'. +-- | @circuit-notation@ plugin repurposed for "Protocols". plugin :: GHC.Plugin plugin = CN.mkPlugin $ CN.ExternalNames - { CN.circuitCon = CN.thName 'Circuit - , CN.circuitTyCon = CN.thName ''Circuit - , CN.circuitTTyCon = CN.thName ''CircuitT - , CN.runCircuitName = CN.thName 'toSignals + { CN.circuitCon = CN.thName 'TaggedCircuit + , CN.fwdAndBwdTypes = \case + CN.Fwd -> CN.thName ''Fwd + CN.Bwd -> CN.thName ''Bwd , CN.fwdBwdCon = CN.thName '(,) + , CN.runCircuitName = CN.thName 'runTagCircuit + , CN.tagBundlePat = CN.thName 'TaggedBundle + , CN.tagName = CN.thName 'Tagged + , CN.tagTName = CN.thName ''Tagged + , CN.trivialBwd = CN.thName 'units } diff --git a/stack.yaml b/stack.yaml index 744519bb..21001dab 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,7 +5,7 @@ packages: extra-deps: - git: https://github.com/cchalmers/circuit-notation.git - commit: 618e37578e699df235f2e7150108b6401731919b + commit: 565d4811cff6a597ee577dabd81b460e941fcb14 - tasty-hedgehog-1.2.0.0 - clash-prelude-1.6.3 - clash-prelude-hedgehog-1.6.3 diff --git a/tests/Tests/Protocols/Plugin.hs b/tests/Tests/Protocols/Plugin.hs index 27fcb160..bf279f09 100644 --- a/tests/Tests/Protocols/Plugin.hs +++ b/tests/Tests/Protocols/Plugin.hs @@ -4,6 +4,9 @@ -- want to add this to 'ghc-options' in your cabal file. {-# OPTIONS -fplugin=Protocols.Plugin #-} +-- For debugging purposes: +-- {-# OPTIONS -fplugin-opt=Protocols.Plugin:debug #-} + module Tests.Protocols.Plugin where import qualified Clash.Prelude as C