From 0d7abf577302c66c3a25207896f1c0cf35ac003f Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Mon, 13 Sep 2021 16:33:30 +0200 Subject: [PATCH] Don't loop on hidden recursive data type The recursive occurrence was hiding behind a type family. So we should always expand type families when checking whether a data type is recursive. Fixes #1921 --- changelog/2021-09-13T16_31_59+02_00_fix_1921 | 1 + clash-lib/src/Clash/Netlist/Util.hs | 27 +++++++-- tests/Main.hs | 1 + tests/shouldwork/Issues/T1921.hs | 64 ++++++++++++++++++++ 4 files changed, 89 insertions(+), 4 deletions(-) create mode 100644 changelog/2021-09-13T16_31_59+02_00_fix_1921 create mode 100644 tests/shouldwork/Issues/T1921.hs diff --git a/changelog/2021-09-13T16_31_59+02_00_fix_1921 b/changelog/2021-09-13T16_31_59+02_00_fix_1921 new file mode 100644 index 0000000000..fa458a8b12 --- /dev/null +++ b/changelog/2021-09-13T16_31_59+02_00_fix_1921 @@ -0,0 +1 @@ +FIXED: Dont' loop on recursive data types hiding behind type families [#1921](https://github.com/clash-lang/clash-compiler/issues/1921) diff --git a/clash-lib/src/Clash/Netlist/Util.hs b/clash-lib/src/Clash/Netlist/Util.hs index 359058a3f3..bc99df5a3a 100644 --- a/clash-lib/src/Clash/Netlist/Util.hs +++ b/clash-lib/src/Clash/Netlist/Util.hs @@ -90,8 +90,8 @@ import Clash.Core.Term import Clash.Core.TermInfo import Clash.Core.TyCon (TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons) -import Clash.Core.Type (Type (..), TypeView (..), - coreView1, splitTyConAppM, tyView, TyVar) +import Clash.Core.Type + (Type (..), TyVar, TypeView (..), coreView1, normalizeType, splitTyConAppM, tyView) import Clash.Core.Util (substArgTys, tyLitShow) import Clash.Core.Var @@ -603,11 +603,30 @@ hasUnconstrainedExistential tcm dc = -- | Simple check if a TyCon is recursively defined. +-- +-- Note [Look through type families in recursivity check] +-- +-- Consider: +-- +-- @ +-- data SList :: [Type] -> Type where +-- SNil :: SList [] +-- CSons :: a -> Sing (as :: [k]) -> SList (a:as) +-- +-- type family Sing [a] = SList [a] +-- @ +-- +-- Without looking through type families, we would think that /SList/ is not +-- recursive. This lead to issue #1921 isRecursiveTy :: TyConMap -> TyConName -> Bool isRecursiveTy m tc = case tyConDataCons (m `lookupUniqMap'` tc) of [] -> False - dcs -> let argTyss = map dcArgTys dcs - argTycons = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss + dcs -> let argTyss = map dcArgTys dcs + argTycons = (map fst . catMaybes) + $ (concatMap . map) + -- Note [Look through type families in recursivity check] + (splitTyConAppM . normalizeType m) + argTyss in tc `elem` argTycons -- | Determines if a Core type is translatable to a HWType given a function that diff --git a/tests/Main.hs b/tests/Main.hs index c0cc772118..bcef8ac821 100755 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -532,6 +532,7 @@ runClashTest = defaultMain $ clashTestRoot , outputTest "T431" def{hdlTargets=[VHDL]} , clashLibTest "T779" def{hdlTargets=[Verilog]} , outputTest "T1881" def{hdlSim=False} + , runTest "T1921" def{hdlTargets=[Verilog], hdlSim=False} ] <> if compiledWith == Cabal then -- This tests fails without environment files present, which are only diff --git a/tests/shouldwork/Issues/T1921.hs b/tests/shouldwork/Issues/T1921.hs new file mode 100644 index 0000000000..37019be335 --- /dev/null +++ b/tests/shouldwork/Issues/T1921.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP + , DerivingStrategies + , GeneralizedNewtypeDeriving + , LambdaCase + , AllowAmbiguousTypes + , ApplicativeDo + , StandaloneDeriving #-} + +module T1921 where + +import Clash.Prelude +import Control.Lens +import Data.Default +#if MIN_VERSION_singletons(3,0,0) +import Prelude.Singletons +import GHC.TypeLits.Singletons as TL +#else +import Data.Singletons.Prelude +import Data.Singletons.TypeLits as TL +#endif + +topEntity :: Clock System -> Reset System -> Enable System -> Signal System (Unsigned 8) +topEntity = exposeClockResetEnable fibonacciLFSR8 + +-- Straightforward newtype +newtype LFSRState n = LFSRState { runLFSRState :: BitVector n } + deriving newtype (NFDataX, AutoReg) +instance KnownNat n => Default (LFSRState n) where + def = LFSRState (fromIntegral 1) + +fibonacciLFSR8 :: HiddenClockResetEnable dom => Signal dom (Unsigned 8) +fibonacciLFSR8 = fibonacciLFSRType @('[3,4,5,7]) @8 + +fibonacciLFSRType + :: forall (taps :: [Nat]) (n :: Nat) dom + . SingI taps + => KnownNat n + => HiddenClockResetEnable dom + => Signal dom (Unsigned n) +fibonacciLFSRType = + let lfsr = autoReg def (LFSRState <$> lfsr') + lfsr' = do lfsrState <- lfsr + -- shift the bit register by one, and then replace + -- the bit on the end by xor of the taps (via go) + return $ + shiftL (runLFSRState lfsrState) 1 + & ix 0 + .~ go lfsrState (sing :: Sing taps) + in unpack <$> lfsr' + + where + go :: forall (n :: Nat) (indices :: [Nat]) + . SingI indices + => KnownNat n + => LFSRState n -> SList indices -> Bit + go b@(LFSRState bs) = \case + -- If there is only one tap left, return that bit + (SCons a SNil) -> withKnownNat a + $ bs ^?! ix (fromIntegral $ TL.natVal a) + -- XOR a tapped bit with the remaining taps + (SCons a as) -> withSingI as $ withKnownNat a + $ xor (bs ^?! ix (fromIntegral $ TL.natVal a)) (go b as) + -- This should never happen (we can't have no taps) + SNil -> error "A no-tap LFSR is ill-defined"