diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,36 @@ # Changelog for the Clash project +## 1.2.2 *June 12th 2020* + + +* Changed: + * The hardwired functions to unroll primitive definitions for 'zipWith', 'map', 'foldr', and 'init' have been changed to only unroll a single step, whereas they would previously unroll the whole definition in one step. This allows Clash to take advantage of the lazy nature of these functions, in turn speeding up compilation speeds significantly in some cases. Part of [PR 1354](https://github.com/clash-lang/clash-compiler/pull/1354). + +* Added: + * Support for GHC 8.10 + * Ability to load designs from precompiled modules (i.e., stored in a package database). See [#1172](https://github.com/clash-lang/clash-compiler/pull/1172) + * Support for '-main-is' when used with `--vhdl`, `--verilog`, or `--systemverilog` + * A partial instance for `NFDataX (Signal domain a)` + +* Fixed: + * Clash's evaluator now inlines work free definitions, preventing [situations where it would otherwise get stuck in an infinite loop](https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374) + * `caseCon` doesn't apply type-substitution correctly [#1340](https://github.com/clash-lang/clash-compiler/issues/1340) + * Clash generates illegal SystemVerilog slice [#1313](https://github.com/clash-lang/clash-compiler/issues/1313) + * Fix result type of head and tail Verilog blackboxes [#1351](https://github.com/clash-lang/clash-compiler/issues/1351) + * Certain recursive let-expressions in side a alternatives of a case-expression throw the Clash compiler into an infinite loop [#1316](https://github.com/clash-lang/clash-compiler/issues/1316) + * Fixes issue with one of Clash's transformations, `inlineCleanup`, introducing free variables [#1337](https://github.com/clash-lang/clash-compiler/issues/1337) + * Fails to propagate type information of existential type [#1310](https://github.com/clash-lang/clash-compiler/issues/1310) + * Certain case-expressions throw the Clash compiler into an infinite loop [#1320](https://github.com/clash-lang/clash-compiler/issues/1320) + * Added blackbox implementation for 'Clash.Sized.Vector.iterateI', hence making it usable as a register reset value [#1240](https://github.com/clash-lang/clash-compiler/issues/1240) + * `iterate` and `iterateI` can now be used in reset values [#1240](https://github.com/clash-lang/clash-compiler/issues/1240) + * Prim evaluation fails on undefined arguments [#1297](https://github.com/clash-lang/clash-compiler/issues/1297) + * Missing re-indexing in (Un)Signed fromSLV conversion [#1292](https://github.com/clash-lang/clash-compiler/issues/1292) + * VHDL: generate a type qualification inside ~TOBV, fixes [#1360](https://github.com/clash-lang/clash-compiler/issues/1360) + ## 1.2.1 *April 23rd 2020* * Changed: - * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183) - * Infix use of `deepseqX` is now right-associative + * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183) + * Infix use of `deepseqX` is now right-associative * Added: * Add 'natToInteger', 'natToNatural', and 'natToNum'. Similar to 'snatTo*', but works solely on a type argument instead of an SNat. @@ -11,12 +38,12 @@ * Added NFDataX instances for `Data.Monoid.{First,Last}` * Fixed: - * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations. - * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242) - * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any` - * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256) - * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254) - * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264) + * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations. + * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242) + * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any` + * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256) + * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254) + * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264) ## 1.2.0 *March 5th 2020* As promised when releasing 1.0, we've tried our best to keep the API stable. We diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-prelude -Version: 1.2.1 +Version: 1.2.2 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: Clash is a functional hardware description language that borrows both its @@ -316,18 +316,19 @@ data-default-class >= 0.1.2 && < 0.2, integer-gmp >= 0.5.1.0 && < 1.1, deepseq >= 1.4.1.0 && < 1.5, - ghc-prim >= 0.5.1.0 && < 0.6, + ghc-prim >= 0.5.1.0 && < 0.7, ghc-typelits-extra >= 0.3.3 && < 0.5, ghc-typelits-knownnat >= 0.7.2 && < 0.8, ghc-typelits-natnormalise >= 0.7.2 && < 0.8, hashable >= 1.2.1.0 && < 1.4, half >= 0.2.2.3 && < 1.0, + interpolate >= 0.2 && < 0.3, lens >= 4.10 && < 4.20, recursion-schemes >= 5.1 && < 5.2, QuickCheck >= 2.7 && < 2.15, reflection >= 2 && < 2.2, singletons >= 1.0 && < 3.0, - template-haskell >= 2.12.0.0 && < 2.16, + template-haskell >= 2.12.0.0 && < 2.17, th-abstraction >= 0.2.10 && < 0.4.0, th-lift >= 0.7.0 && < 0.9, th-orphans >= 0.13.1 && < 1.0, @@ -336,6 +337,7 @@ time >= 1.8 && < 1.11, transformers >= 0.5.2.0 && < 0.6, type-errors >= 0.2.0.0 && < 0.3, + uniplate >= 1.6.12 && < 1.7, vector >= 0.11 && < 1.0 test-suite doctests @@ -352,7 +354,7 @@ else build-depends: base, - doctest >= 0.9.1 && < 0.17, + doctest >= 0.9.1 && < 0.18, clash-prelude if impl(ghc >= 8.6) build-depends: @@ -376,7 +378,7 @@ base, hint >= 0.7 && < 0.10, quickcheck-classes-base >= 0.6 && < 1.0, - tasty >= 1.2 && < 1.3, + tasty >= 1.2 && < 1.4, tasty-hunit, tasty-quickcheck, template-haskell diff --git a/src/Clash/Annotations/TH.hs b/src/Clash/Annotations/TH.hs --- a/src/Clash/Annotations/TH.hs +++ b/src/Clash/Annotations/TH.hs @@ -73,6 +73,7 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup as Semigroup #endif +import Data.Maybe ( catMaybes ) import Language.Haskell.TH import Data.Functor.Foldable ( para ) @@ -80,11 +81,13 @@ import Control.Lens ( (%~), (&), (.~) , _1, _2, _3, view ) -import Control.Monad (mfilter, liftM2) +import Control.Monad (mfilter, liftM2, forM, zipWithM) import Control.Monad.Trans.Reader (ReaderT(..), asks, local) import Control.Monad.Trans.Class (lift) import Language.Haskell.TH.Instances ( ) import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Syntax (qRecover) +import Data.Generics.Uniplate.Data (rewrite) import Clash.Annotations.TopEntity ( PortName(..) , TopEntity(..) @@ -241,6 +244,15 @@ xs -> BackTrack xs _ -> return names +-- This shouldn't reduce +type family PortLabel where + +-- Replace (:::) annotations with a stuck type family, to inhibit unifyTypes to reduce it +guardPorts :: Type -> Type +guardPorts = rewrite $ \case + AppT (ConT split) name@(LitT (StrTyLit _)) | split == ''(:::) -> Just $ AppT (ConT ''PortLabel) name + _ -> Nothing + -- | Recursively walking a 'Type' tree and building a list of 'PortName's. typeTreeToPorts :: TypeF (Type, Tracked Q (Naming [PortName])) @@ -248,7 +260,7 @@ -> Tracked Q (Naming [PortName]) typeTreeToPorts (AppTF (AppT (ConT split) (LitT (StrTyLit name)), _) (_,c)) -- Is there a ' ::: ' annotation? - | split == ''(:::) + | split == ''PortLabel -- We found our split. If: -- - We only have no names from children: use split name as PortName -- - We have children reporting names: use split name as name to PortProduct @@ -295,18 +307,15 @@ -- 2. Match argument lengths, substitute types, and then insert the port -- tree FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bds _ _) eqs) _ - | length bds == length xs -> - case filter ((==) xs . applyFamilyBindings xs info . tySynArgs) eqs of -#if MIN_VERSION_template_haskell(2,15,0) - [TySynEqn _ _ r] -> -#else - [TySynEqn _ r] -> -#endif - gatherNames (applyFamilyBindings xs info r) - - -- We didn't find a (single) matching instance so give up. Is this - -- impossible? - _ -> return $ Complete [] + | length bds == length xs -> do + matches <- lift $ forM eqs $ \eq -> qRecover (return Nothing) . fmap Just $ do + sub <- mconcat <$> zipWithM (\l r -> unifyTypes [l, r]) xs (tySynArgs eq) + return $ applySubstitution sub $ tySynRHS eq + case catMaybes matches of + (r:_) -> gatherNames r + -- We didn't find any matching instances (i.e. the + -- type family application is stuck) so give up. + [] -> return $ Complete [] -- 3. Match argument lengths then: -- - Substitute port tree for type family @@ -373,6 +382,12 @@ tySynArgs (TySynEqn args _) = args #endif +#if MIN_VERSION_template_haskell(2,15,0) + tySynRHS (TySynEqn _ _ r) = r +#else + tySynRHS (TySynEqn _ r) = r +#endif + familyBindings (FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ xs _ _) _) _) = Just xs familyBindings (FamilyI (OpenTypeFamilyD (TypeFamilyHead _ xs _ _)) _) = Just xs familyBindings (FamilyI (DataFamilyD _ xs _) _) = Just xs @@ -390,7 +405,7 @@ -- ^ Type to investigate -> Tracked Q (Naming [PortName]) gatherNames = - para typeTreeToPorts + para typeTreeToPorts . guardPorts -- | Build a possible failing 'PortName' tree and unwrap the 'Naming' result. buildPorts diff --git a/src/Clash/Annotations/TopEntity.hs b/src/Clash/Annotations/TopEntity.hs --- a/src/Clash/Annotations/TopEntity.hs +++ b/src/Clash/Annotations/TopEntity.hs @@ -197,6 +197,7 @@ -} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Safe #-} @@ -214,7 +215,10 @@ import GHC.Generics import qualified Language.Haskell.TH as TH -import Language.Haskell.TH.Syntax (Lift(lift)) +import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Data.Data -- | TopEntity annotation @@ -260,6 +264,9 @@ , lift output ] lift (TestBench _) = error "Cannot lift a TestBench" +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif -- | Give port names for arguments/results. -- diff --git a/src/Clash/Class/BitPack/Internal.hs b/src/Clash/Class/BitPack/Internal.hs --- a/src/Clash/Class/BitPack/Internal.hs +++ b/src/Clash/Class/BitPack/Internal.hs @@ -9,7 +9,7 @@ module Clash.Class.BitPack.Internal (deriveBitPackTuples) where import Clash.CPP (maxTupleSize) -import Language.Haskell.TH.Compat (mkTySynInstD) +import Language.Haskell.TH.Compat (mkTySynInstD,mkTupE) import Control.Monad (replicateM) import Data.List (foldl') import GHC.TypeLits (KnownNat) @@ -69,7 +69,7 @@ [ Clause [ TupP $ map VarP names ] ( let (e:es) = map VarE names - in NormalB (TupE [e,TupE es]) + in NormalB (mkTupE [e,mkTupE es]) ) [] ] @@ -94,7 +94,7 @@ ( NormalB $ VarE unpackName `AppE` VarE y ) [] ] - ( TupE $ map VarE names ) + ( mkTupE $ map VarE names ) ) [] ] diff --git a/src/Clash/Clocks/Deriving.hs b/src/Clash/Clocks/Deriving.hs --- a/src/Clash/Clocks/Deriving.hs +++ b/src/Clash/Clocks/Deriving.hs @@ -13,6 +13,7 @@ import Control.Monad (foldM) import Clash.Signal.Internal +import Language.Haskell.TH.Compat import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lib import Unsafe.Coerce (unsafeCoerce) @@ -40,7 +41,7 @@ -- Implementation of 'clocks' let noInline = PragmaD $ InlineP (mkName "clocks") NoInline FunLike AllPhases let clkImpls = replicate n (clkImpl clk) - let instTuple = TupE $ clkImpls ++ [AppE (VarE 'unsafeCoerce) (VarE rst)] + let instTuple = mkTupE $ clkImpls ++ [AppE (VarE 'unsafeCoerce) (VarE rst)] let funcBody = NormalB instTuple let instFunc = FunD (mkName "clocks") [Clause [VarP clk, VarP rst] funcBody []] diff --git a/src/Clash/Promoted/Nat.hs b/src/Clash/Promoted/Nat.hs --- a/src/Clash/Promoted/Nat.hs +++ b/src/Clash/Promoted/Nat.hs @@ -77,6 +77,9 @@ import GHC.Natural (naturalFromInteger) import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift (..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Numeric.Natural (Natural) import Unsafe.Coerce (unsafeCoerce) import Clash.XException (ShowX (..), showsPrecXWith) @@ -97,6 +100,9 @@ instance Lift (SNat n) where lift s = sigE [| SNat |] (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s))) +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif -- | Create an @`SNat` n@ from a proxy for /n/ snatProxy :: KnownNat n => proxy n -> SNat n diff --git a/src/Clash/Promoted/Symbol.hs b/src/Clash/Promoted/Symbol.hs --- a/src/Clash/Promoted/Symbol.hs +++ b/src/Clash/Promoted/Symbol.hs @@ -4,6 +4,7 @@ Maintainer : Christiaan Baaij -} +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskellQuotes #-} @@ -29,6 +30,9 @@ where tt = LitT (StrTyLit (ssymbolToString t)) +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif instance Show (SSymbol s) where showsPrec d s@SSymbol = showParen (d > appPrec) $ diff --git a/src/Clash/Signal/Bundle/Internal.hs b/src/Clash/Signal/Bundle/Internal.hs --- a/src/Clash/Signal/Bundle/Internal.hs +++ b/src/Clash/Signal/Bundle/Internal.hs @@ -11,6 +11,7 @@ import Data.List (foldl') import qualified Language.Haskell.TH.Syntax as TH import Language.Haskell.TH +import Language.Haskell.TH.Compat idPrimitive :: TH.Name -> DecQ idPrimitive nm = @@ -103,7 +104,7 @@ (TupP (map VarP asNames)) (NormalB ( tNm `seqXE` (sNm `seqE` (VarE unbundlePrimName `AppE` VarE sTailNm)))) []] - (TupE + (mkTupE (zipWith (\a as -> UInfixE (VarE a) (ConE '(:-)) (VarE as)) aNames @@ -131,7 +132,7 @@ bundleFmap = UInfixE - (LamE (map VarP aPrimeNames) (TupE (map VarE aPrimeNames))) + (LamE (map VarP aPrimeNames) (mkTupE (map VarE aPrimeNames))) (VarE '(<$>)) (VarE (head aNames)) diff --git a/src/Clash/Signal/Internal.hs b/src/Clash/Signal/Internal.hs --- a/src/Clash/Signal/Internal.hs +++ b/src/Clash/Signal/Internal.hs @@ -146,7 +146,7 @@ import GHC.Stack (HasCallStack) import GHC.TypeLits (KnownSymbol, Nat, Symbol, type (<=)) import Language.Haskell.TH.Syntax -- (Lift (..), Q, Dec) -import Language.Haskell.TH.Compat (mkTySynInstD) +import Language.Haskell.TH.Compat import Numeric.Natural (Natural) import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Property, property) @@ -155,7 +155,7 @@ import Clash.Promoted.Nat (SNat (..), snatToNum, snatToNatural) import Clash.Promoted.Symbol (SSymbol (..), ssymbolToString) import Clash.XException - (NFDataX, errorX, deepseqX, defaultSeqX, deepErrorX, seqX) + (NFDataX(..), errorX, isX, deepseqX, defaultSeqX, seqX) {- $setup >>> :set -XDataKinds @@ -646,6 +646,9 @@ instance Lift a => Lift (Signal dom a) where lift ~(x :- _) = [| signal# x |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif instance Default a => Default (Signal dom a) where def = signal# def @@ -675,6 +678,14 @@ appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as) -- See [NOTE: Lazy ap] {-# NOINLINE appSignal# #-} {-# ANN appSignal# hasBlackBox #-} + +instance NFDataX a => NFDataX (Signal domain a) where + deepErrorX = pure . deepErrorX + ensureSpine s = case isX s of + Left e -> deepErrorX e + Right (a :- s') -> ensureSpine a :- ensureSpine s' + hasUndefined = error "hasUndefined on (Signal domain a): No sensible implementation exists" + rnfX = error "rnfX on (Signal domain a): No sensible implementation exists" {- NOTE: Lazy ap Signal's ap, i.e (Applicative.<*>), must be lazy in it's second argument: diff --git a/src/Clash/Sized/Fixed.hs b/src/Clash/Sized/Fixed.hs --- a/src/Clash/Sized/Fixed.hs +++ b/src/Clash/Sized/Fixed.hs @@ -64,6 +64,7 @@ -} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -123,6 +124,9 @@ import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, mkName, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Test.QuickCheck (Arbitrary, CoArbitrary) import Clash.Class.BitPack (BitPack (..)) @@ -538,6 +542,9 @@ (decFixed (typeRep (asRepProxy f)) (natVal (asIntProxy f)) (natVal f)) +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif decFixed :: TypeRep -> Integer -> Integer -> TypeQ decFixed r i f = do diff --git a/src/Clash/Sized/Internal/BitVector.hs b/src/Clash/Sized/Internal/BitVector.hs --- a/src/Clash/Sized/Internal/BitVector.hs +++ b/src/Clash/Sized/Internal/BitVector.hs @@ -148,6 +148,9 @@ import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE, Lit(..), litE, Pat, litP) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), arbitraryBoundedIntegral, coarbitraryIntegral, shrinkIntegral) @@ -232,6 +235,9 @@ instance Lift Bit where lift (Bit m i) = [| fromInteger## $(litE (WordPrimL (toInteger m))) i |] {-# NOINLINE lift #-} +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif instance Eq Bit where (==) = eq## @@ -924,6 +930,9 @@ instance KnownNat n => Lift (BitVector n) where lift bv@(BV m i) = sigE [| fromInteger# m $(litE (IntegerL (toInteger i))) |] (decBitVector (natVal bv)) {-# NOINLINE lift #-} +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif decBitVector :: Integer -> TypeQ decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n) diff --git a/src/Clash/Sized/Internal/Index.hs b/src/Clash/Sized/Internal/Index.hs --- a/src/Clash/Sized/Internal/Index.hs +++ b/src/Clash/Sized/Internal/Index.hs @@ -75,6 +75,9 @@ import Text.Read (Read (..), ReadPrec) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import GHC.Generics (Generic) import GHC.Natural (Natural, naturalFromInteger) #if MIN_VERSION_base(4,12,0) @@ -399,6 +402,9 @@ instance KnownNat n => Lift (Index n) where lift u@(I i) = sigE [| fromInteger# i |] (decIndex (natVal u)) {-# NOINLINE lift #-} +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif decIndex :: Integer -> TypeQ decIndex n = appT (conT ''Index) (litT $ numTyLit n) diff --git a/src/Clash/Sized/Internal/Signed.hs b/src/Clash/Sized/Internal/Signed.hs --- a/src/Clash/Sized/Internal/Signed.hs +++ b/src/Clash/Sized/Internal/Signed.hs @@ -99,6 +99,9 @@ import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), arbitraryBoundedIntegral, coarbitraryIntegral, shrinkIntegral) @@ -568,6 +571,9 @@ instance KnownNat n => Lift (Signed n) where lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s)) {-# NOINLINE lift #-} +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif decSigned :: Integer -> TypeQ decSigned n = appT (conT ''Signed) (litT $ numTyLit n) diff --git a/src/Clash/Sized/Internal/Unsigned.hs b/src/Clash/Sized/Internal/Unsigned.hs --- a/src/Clash/Sized/Internal/Unsigned.hs +++ b/src/Clash/Sized/Internal/Unsigned.hs @@ -97,6 +97,9 @@ import GHC.Word (Word (..), Word8 (..), Word16 (..), Word32 (..)) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), arbitraryBoundedIntegral, coarbitraryIntegral) @@ -458,6 +461,9 @@ instance KnownNat n => Lift (Unsigned n) where lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u)) {-# NOINLINE lift #-} +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif decUnsigned :: Integer -> TypeQ decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n) diff --git a/src/Clash/Sized/RTree.hs b/src/Clash/Sized/RTree.hs --- a/src/Clash/Sized/RTree.hs +++ b/src/Clash/Sized/RTree.hs @@ -59,6 +59,9 @@ import Data.Proxy (Proxy (..)) import GHC.TypeLits (KnownNat, Nat, type (+), type (^), type (*)) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Prelude hiding ((++), (!!)) import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) @@ -210,6 +213,9 @@ instance Lift a => Lift (RTree d a) where lift (LR_ a) = [| LR_ a |] lift (BR_ t1 t2) = [| BR_ $(lift t1) $(lift t2) |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif instance (KnownNat d, Arbitrary a) => Arbitrary (RTree d a) where arbitrary = sequenceA (trepeat arbitrary) diff --git a/src/Clash/Sized/Vector.hs b/src/Clash/Sized/Vector.hs --- a/src/Clash/Sized/Vector.hs +++ b/src/Clash/Sized/Vector.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Trustworthy #-} @@ -115,12 +116,16 @@ import GHC.Prim ((==#),(<#),(-#)) import Language.Haskell.TH (ExpQ) import Language.Haskell.TH.Syntax (Lift(..)) +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Compat +#endif import Prelude hiding ((++), (!!), concat, concatMap, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3) +import qualified Data.String.Interpolate as I import qualified Prelude as P import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) import Unsafe.Coerce (unsafeCoerce) @@ -1489,12 +1494,17 @@ -- \"'iterateI' @f z@\" corresponds to the following circuit layout: -- -- <> -iterateI :: KnownNat n => (a -> a) -> a -> Vec n a +iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a iterateI f a = xs where xs = init (a `Cons` ws) ws = map f (lazyV xs) -{-# INLINE iterateI #-} +{-# NOINLINE iterateI #-} +{-# ANN iterateI (InlinePrimitive [VHDL,Verilog,SystemVerilog] [I.i| [{ + "BlackBoxHaskell": { + "name": "Clash.Sized.Vector.iterateI" + , "templateFunction": "Clash.Primitives.Sized.Vector.iterateBBF" + }}] |]) #-} -- | \"'unfoldr @n f s@\" builds a vector of length @n@ from a seed value @s@, -- where every element @a@ is created by successive calls of @f@ on @s@. Unlike @@ -2282,6 +2292,9 @@ instance Lift a => Lift (Vec n a) where lift Nil = [| Nil |] lift (x `Cons` xs) = [| x `Cons` $(lift xs) |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntyped +#endif instance (KnownNat n, Arbitrary a) => Arbitrary (Vec n a) where arbitrary = traverse# id $ repeat arbitrary diff --git a/src/Clash/XException/TH.hs b/src/Clash/XException/TH.hs --- a/src/Clash/XException/TH.hs +++ b/src/Clash/XException/TH.hs @@ -13,6 +13,7 @@ import Data.Either (isLeft) import Data.List (intersperse) +import Language.Haskell.TH.Compat import Language.Haskell.TH.Syntax -- Spliced in in XException, so these names should be in scope: @@ -139,14 +140,14 @@ ensureSpineDecl = FunD ensureSpineName [ Clause [TildeP (TupP (map VarP names))] - (NormalB (TupE (map (AppE (VarE ensureSpineName) . VarE) names))) + (NormalB (mkTupE (map (AppE (VarE ensureSpineName) . VarE) names))) [] ] deepErrorXDecl = FunD deepErrorXName [ Clause [VarP s] - (NormalB (TupE (replicate n (VarE deepErrorXName `AppE` VarE s)))) + (NormalB (mkTupE (replicate n (VarE deepErrorXName `AppE` VarE s)))) [] ] diff --git a/src/Language/Haskell/TH/Compat.hs b/src/Language/Haskell/TH/Compat.hs --- a/src/Language/Haskell/TH/Compat.hs +++ b/src/Language/Haskell/TH/Compat.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Language.Haskell.TH.Compat where -import Language.Haskell.TH +import Language.Haskell.TH.Syntax -- | Compatibility helper to create TySynInstD mkTySynInstD :: Name -> [Type] -> Type -> Dec @@ -14,4 +14,16 @@ TySynInstD tyConNm (TySynEqn tyArgs rhs) +#endif + +-- | Compatibility helper to create (total) tuple expressions +mkTupE :: [Exp] -> Exp +mkTupE = TupE +#if MIN_VERSION_template_haskell(2,16,0) + . map Just +#endif + +#if MIN_VERSION_template_haskell(2,16,0) +liftTypedFromUntyped :: Lift a => a -> Q (TExp a) +liftTypedFromUntyped = unsafeTExpCoerce . lift #endif diff --git a/tests/Clash/Tests/TopEntityGeneration.hs b/tests/Clash/Tests/TopEntityGeneration.hs --- a/tests/Clash/Tests/TopEntityGeneration.hs +++ b/tests/Clash/Tests/TopEntityGeneration.hs @@ -43,6 +43,11 @@ type family CF x y z where CF Int Int Int = ("cfiii" ::: Single) CF Bool Int Int = ("cfbii" ::: Single) + +type family OrderedCF b f a where + OrderedCF 'True f a = f a + OrderedCF b f a = () + type family OF x y z type instance OF Int Int Int = ("ofiii" ::: Single) type instance OF Bool Int Int = ("ofbii" ::: Single) @@ -58,6 +63,12 @@ data Passthrough a b = Passthrough a b +data HKD f = HKD + { fd1 :: OrderedCF 'True f ("fd1" ::: Int) + , fd2 :: OrderedCF 'True f ("fd2" ::: Bool) + } + + topEntity1 :: "in1" ::: Signal System Int -> "in2" ::: Signal System Bool -> "out" ::: Signal System Int @@ -129,6 +140,7 @@ -> Signal System (OF Bool Int Int) -> Signal System (X Int Int Int) -> Signal System (X Bool Int Int) + -> "hkd" ::: HKD (Signal System) -> Signal System Single topEntity4 = undefined makeTopEntity 'topEntity4 @@ -144,6 +156,7 @@ , PortName "ofbii_s" , PortProduct "" [PortName "xiii", PortName "xiii2"] , PortName "xbii" + , PortProduct "hkd" [PortName "fd1", PortName "fd2"] ] (PortName "s")