Don't loop on hidden recursive data type

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)

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

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

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"