Merge pull request #1059 from clash-lang/nested-product-names

Generate unique names for port wires. Fix #1041

Author: Alex McKenna

CHANGELOG.md

@@ -85,6 +85,7 @@
   * [#1030](https://github.com/clash-lang/clash-compiler/issues/1030): `bindConstantVar` will bind (workfree) constructs
   * [#1034](https://github.com/clash-lang/clash-compiler/issues/1034): Error (10137): object "pllLock" on lhs must have a variable data type
   * [#1046](https://github.com/clash-lang/clash-compiler/issues/1046): Don't confuse term/type namespaces in 'lookupIdSubst'
+  * [#1041](https://github.com/clash-lang/clash-compiler/issues/1041): Nested product types incorrectly decomposed into ports
 
 * Fixes without issue reports:
   * Fix bug in `rnfX` defined for `Down` ([baef30e](https://github.com/clash-lang/clash-compiler/commit/baef30eae03dc02ba847ffbb8fae7f365c5287c2))

clash-lib/src/Clash/Netlist/Util.hs

@@ -1272,8 +1272,8 @@ mkOutput' pM = case pM of
       pN <- uniquePortName p o
       return ([(pN,hwty)],[],pN)
 
-    go' (PortProduct p ps) (o,hwty) = do
-      pN <- uniquePortName p o
+    go' (PortProduct p ps) (_,hwty) = do
+      pN <- mkUniqueIdentifier Basic (Text.pack p)
       let (attrs, hwty') = stripAttributes hwty
       case hwty' of
         Vector sz hwty'' -> do
@@ -1298,12 +1298,12 @@ mkOutput' pM = case pM of
           results <- zipWithM appendIdentifier (map (pN,) hwtys) [0..]
           let ps'            = extendPorts $ map (prefixParent p) ps
           (ports,decls,ids) <- unzip3 <$> uncurry (zipWithM mkOutput') (ps', results)
+          let netdecl = NetDecl Nothing pN hwty'
           case ids of
-            [i] -> let netdecl = NetDecl Nothing pN hwty'
-                       assign  = Assignment i (Identifier pN Nothing)
+            [i] -> let assign  = Assignment i (Identifier pN Nothing)
                    in  return (concat ports,netdecl:assign:concat decls,pN)
-            _   -> let netdecl = NetDecl Nothing pN hwty'
-                       assigns = zipWith (assignId pN hwty' 0) ids [0..]
+
+            _   -> let assigns = zipWith (assignId pN hwty' 0) ids [0..]
                    in  if null attrs then
                          return (concat ports,netdecl:assigns ++ concat decls,pN)
                        else

tests/shouldwork/Naming/T1041.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module T1041 where
+
+import Prelude as P
+
+import Clash.Prelude
+import Clash.Netlist.Types
+
+import Test.Tasty.Clash
+import Test.Tasty.Clash.NetlistTest
+
+data VGASync dom = VGASync
+    { vgaHSync :: Signal dom (Unsigned 8)
+    , vgaVSync :: Signal dom (Unsigned 8)
+    , vgaDE    :: Signal dom (Unsigned 8)
+    }
+
+data VGAOut dom = VGAOut
+    { vgaSync  :: VGASync dom
+    , vgaR     :: Signal dom (Unsigned 8)
+    , vgaG     :: Signal dom (Unsigned 8)
+    , vgaB     :: Signal dom (Unsigned 8)
+    }
+
+{-# ANN getVgaOut
+   (Synthesize
+     { t_name   = "Pattern"
+     , t_inputs =
+        [ PortName "CLK_25MHZ"
+        , PortName "RESET"
+        ]
+     , t_output =
+        PortProduct "VGA"
+          [ PortProduct ""
+            [ PortName "HSYNC"
+            , PortName "VSYNC"
+            , PortName "DE"
+            ]
+          , PortName "RED"
+          , PortName "GREEN"
+          , PortName "BLUE"
+          ]
+     }) #-}
+getVgaOut :: Clock System -> Reset System -> VGAOut System
+getVgaOut clk rst = VGAOut{..}
+ where
+  vgaSync = VGASync{..}
+   where
+    vgaHSync = pure 0
+    vgaVSync = pure 1
+    vgaDE = pure 2
+
+  vgaR = pure 3
+  vgaG = pure 4
+  vgaB = pure 5
+
+testPath :: FilePath
+testPath = "tests/shouldwork/Naming/T1041.hs"
+
+assertOneVGA :: Component -> IO ()
+assertOneVGA (Component _ _ _ ds)
+  | vgas == 1 = pure ()
+  | otherwise = error $ "Expected one declaration of VGA wire: got " <> show vgas
+ where
+  vgas = P.length (filter isVGADecl ds)
+
+  -- Multiple cases as mkUniqueIdentifier Basic
+  -- in VHDL changes names to be lowercase.
+  --
+  isVGADecl (NetDecl' _ Wire "vga" _ _) = True
+  isVGADecl (NetDecl' _ Wire "VGA" _ _) = True
+  isVGADecl _ = False
+
+getComponent :: (a, b, c, d) -> d
+getComponent (_, _, _, x) = x
+
+mainVHDL :: IO ()
+mainVHDL = do
+  netlist <- runToNetlistStage SVHDL id testPath
+  mapM_ (assertOneVGA . getComponent) netlist
+
+mainVerilog :: IO ()
+mainVerilog = do
+  netlist <- runToNetlistStage SVerilog id testPath
+  mapM_ (assertOneVGA . getComponent) netlist
+
+mainSystemVerilog :: IO ()
+mainSystemVerilog = do
+  netlist <- runToNetlistStage SSystemVerilog id testPath
+  mapM_ (assertOneVGA . getComponent) netlist
+

testsuite/Main.hs

@@ -253,6 +253,7 @@ runClashTest = defaultMain $ clashTestRoot
         [ runTest "T967a" def{hdlSim=False}
         , runTest "T967b" def{hdlSim=False}
         , runTest "T967c" def{hdlSim=False}
+        , netlistTest ("tests" </> "shouldwork" </> "Naming") allTargets [] "T1041" "main"
         ]
       , clashTestGroup "Numbers"
         [ runTest "BitInteger" def