Merge pull request #1057 from clash-lang/fix1033

 Update 'TopEntity' annotations in 'splitArguments'. Fix #1033

Author: martijnbastiaan

CHANGELOG.md

@@ -88,6 +88,7 @@
   * [#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
   * [#1058](https://github.com/clash-lang/clash-compiler/issues/1058): Prevent substitution warning when using type equalities in top entities
+  * [#1033](https://github.com/clash-lang/clash-compiler/issues/1033): Fix issue where Clash breaks when using Clock/Reset/Enable in product types in combination with Synthesize annotations
 
 * Fixes without issue reports:
   * Fix bug in `rnfX` defined for `Down` ([baef30e](https://github.com/clash-lang/clash-compiler/commit/baef30eae03dc02ba847ffbb8fae7f365c5287c2))

benchmark/benchmark-normalization.hs

@@ -4,12 +4,12 @@
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 
 import           Clash.Annotations.BitRepresentation.Internal (CustomReprs)
-import           Clash.Annotations.TopEntity
 import           Clash.Core.TyCon
 import           Clash.Core.Var
 import           Clash.Driver
 import           Clash.Driver.Types
 import           Clash.GHC.Evaluator
+import           Clash.Netlist.Types          (TopEntityT)
 import           Clash.Primitives.Types
 
 import           Criterion.Main
@@ -52,7 +52,7 @@ setupEnv
   :: [FilePath]
   -> FilePath
   -> IO ((BindingMap, TyConMap, IntMap TyConName
-         ,[(Id, Maybe TopEntity, Maybe Id)]
+         ,[TopEntityT]
          ,CompiledPrimMap, CustomReprs, [Id], Id
          )
         ,Supply.Supply

benchmark/common/BenchmarkCommon.hs

@@ -6,7 +6,6 @@
 module BenchmarkCommon where
 
 import Clash.Annotations.BitRepresentation.Internal (CustomReprs, buildCustomReprs)
-import Clash.Annotations.TopEntity
 import Clash.Backend
 import Clash.Backend.VHDL
 import Clash.Core.TyCon
@@ -18,7 +17,7 @@ import Clash.GHC.Evaluator
 import Clash.GHC.GenerateBindings
 import Clash.GHC.NetlistTypes
 import Clash.Netlist.BlackBox.Types (HdlSyn(Other))
-import Clash.Netlist.Types          (HWMap, FilteredHWType)
+import Clash.Netlist.Types          (HWMap, FilteredHWType, TopEntityT, topId)
 import Clash.Primitives.Types
 
 import Util (OverridingBool(..))
@@ -58,7 +57,7 @@ runInputStage
   -> IO (BindingMap
         ,TyConMap
         ,IntMap TyConName
-        ,[(Id, Maybe TopEntity, Maybe Id)]
+        ,[TopEntityT]
         ,CompiledPrimMap
         ,CustomReprs
         ,[Id]
@@ -67,16 +66,15 @@ runInputStage
 runInputStage idirs src = do
   pds <- primDirs backend
   (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <- generateBindings Auto pds idirs [] (hdlKind backend) src Nothing
-  let topEntityNames = map (\(x,_,_) -> x) topEntities
-      ((topEntity,_,_):_) = topEntities
-      tm = topEntity
+  let topEntityNames = map topId topEntities
+      tm = head topEntityNames
   return (bindingsMap,tcm,tupTcm,topEntities, primMap, buildCustomReprs reprs, topEntityNames,tm)
 
 runNormalisationStage
   :: [FilePath]
   -> String
   -> IO (BindingMap
-        ,[(Id, Maybe TopEntity, Maybe Id)]
+        ,[TopEntityT]
         ,CompiledPrimMap
         ,TyConMap
         ,CustomReprs

benchmark/profiling/run/profile-netlist-run.hs

@@ -1,4 +1,3 @@
-import           Clash.Annotations.TopEntity
 import           Clash.Annotations.BitRepresentation.Internal (CustomReprs)
 import           Clash.Backend
 import           Clash.Core.Name
@@ -61,7 +60,7 @@ benchFile idirs src = do
 setupEnv
   :: FilePath
   -> IO (BindingMap
-        ,[(Id, Maybe TopEntity, Maybe Id)]
+        ,[TopEntityT]
         ,CompiledPrimMap'
         ,TyConMap
         ,CustomReprs

clash-ghc/src-ghc/Clash/GHC/GenerateBindings.hs

@@ -41,7 +41,6 @@ import qualified Var                     as GHC
 import qualified SrcLoc                  as GHC
 
 import           Clash.Annotations.BitRepresentation.Internal (DataRepr')
-import           Clash.Annotations.TopEntity (TopEntity)
 import           Clash.Annotations.Primitive (HDL, extractPrim)
 
 import           Clash.Core.Subst        (extendGblSubstList, mkSubst, substTm)
@@ -60,6 +59,7 @@ import           Clash.GHC.GHC2Core
    makeAllTyCons, qualifiedNameString, emptyGHC2CoreState)
 import           Clash.GHC.LoadModules   (ghcLibDir, loadModules)
 import           Clash.Netlist.BlackBox.Util (usedArguments)
+import           Clash.Netlist.Types     (TopEntityT(..))
 import           Clash.Primitives.Types
   (Primitive (..), CompiledPrimMap)
 import           Clash.Primitives.Util   (generatePrimMap)
@@ -85,10 +85,7 @@ generateBindings
   -> IO ( BindingMap
         , TyConMap
         , IntMap TyConName
-        , [( Id
-           , Maybe TopEntity -- (maybe) TopEntity annotation
-           , Maybe Id        -- (maybe) associated testbench
-           )]
+        , [TopEntityT]
         , CompiledPrimMap  -- The primitives found in '.' and 'primDir'
         , [DataRepr']
         )
@@ -124,11 +121,13 @@ generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do
         (\m -> fst (RWS.evalRWS m GHC.noSrcSpan tcMap')) $ mapM (\(topEnt,annM,benchM) -> do
           topEnt' <- coreToName GHC.varName GHC.varUnique qualifiedNameString topEnt
           benchM' <- traverse coreToId benchM
-          return (topEnt',annM,benchM')) topEntities
-      topEntities''                 = map (\(topEnt,annM,benchM) -> case lookupUniqMap topEnt allBindings of
-                                              Just (v,_,_,_) -> (v,annM,benchM)
-                                              Nothing        -> error "This shouldn't happen"
-                                          ) topEntities'
+          return (topEnt', annM, benchM')) topEntities
+      topEntities'' =
+        map (\(topEnt, annM, benchM) ->
+                case lookupUniqMap topEnt allBindings of
+                  Just (v,_,_,_) -> TopEntityT v annM benchM
+                  Nothing -> error "This shouldn't happen"
+            ) topEntities'
   -- Parsing / compiling primitives:
   prepTime  <- startTime `deepseq` primMapC `seq` Clock.getCurrentTime
   let prepStartDiff = reportTimeDiff prepTime startTime

clash-lib/src/Clash/Annotations/TopEntity/Extra.hs

@@ -9,12 +9,14 @@
 module Clash.Annotations.TopEntity.Extra where
 
 import Clash.Annotations.TopEntity (TopEntity, PortName)
+import Clash.Netlist.Types (TopEntityT)
 import Language.Haskell.TH.Syntax
   (ModName, Name, NameFlavour, NameSpace, PkgName, OccName)
 import Data.Binary                 (Binary)
 import Data.Hashable               (Hashable)
 import Control.DeepSeq             (NFData)
 
+instance Binary TopEntityT
 instance Binary TopEntity
 instance Binary PortName
 
@@ -25,6 +27,7 @@ instance Binary ModName
 instance Binary NameSpace
 instance Binary PkgName
 
+instance Hashable TopEntityT
 instance Hashable TopEntity
 instance Hashable PortName
 
@@ -35,6 +38,7 @@ instance Hashable NameSpace
 instance Hashable PkgName
 instance Hashable OccName
 
+instance NFData TopEntityT
 instance NFData TopEntity
 instance NFData PortName
 

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

@@ -982,11 +982,32 @@ shouldSplit0 tcm (TyConApp tcNm tyArgs)
   , [dc] <- tyConDataCons tc
   , let dcArgs  = substArgTys dc tyArgs
   , let dcArgVs = map (tyView . coreView tcm) dcArgs
-  = if any (\ty -> isJust (shouldSplit0 tcm ty) || splitTy ty) dcArgVs then
+  = if any shouldSplitTy dcArgVs && not (isHidden tcNm tyArgs) then
       Just (mkApps (Data dc) (map Right tyArgs), dcArgs)
     else
       Nothing
  where
+  shouldSplitTy :: TypeView -> Bool
+  shouldSplitTy ty = isJust (shouldSplit0 tcm ty) || splitTy ty
+
+  -- Hidden constructs (HiddenClock, HiddenReset, ..) don't need to be split
+  -- because KnownDomain will be filtered anyway during netlist generation due
+  -- to it being a zero-width type
+  --
+  -- TODO: This currently only handles (IP $x, KnownDomain) given that $x is any
+  -- TODO: of the constructs handled in 'splitTy'. In practise this means only
+  -- TODO: HiddenClock, HiddenReset, and HiddenEnable are handled. If a user were
+  -- TODO: to define their own versions with -for example- the elements of the
+  -- TODO: tuple swapped, 'isHidden' wouldn't recognize it. We could generalize
+  -- TODO: this in the future.
+  --
+  isHidden :: Name a -> [Type] -> Bool
+  isHidden nm [a1, a2] | TyConApp a2Nm _ <- tyView a2 =
+       nameOcc nm == "GHC.Classes.(%,%)"
+    && splitTy (tyView (stripIP a1))
+    && nameOcc a2Nm == "Clash.Signal.Internal.KnownDomain"
+  isHidden _ _ = False
+
   -- Currently we're only interested in splitting of Clock, Reset, and Enable
   splitTy (TyConApp tcNm0 _)
     = nameOcc tcNm0 `elem` [ "Clash.Signal.Internal.Clock"
@@ -1025,6 +1046,12 @@ splitShouldSplit tcm = foldr go []
     Just (_,tys) -> splitShouldSplit tcm tys ++ rest
     Nothing      -> ty : rest
 
+-- | Strip implicit parameter wrappers (IP)
+stripIP :: Type -> Type
+stripIP t@(tyView -> TyConApp tcNm [_a1, a2]) =
+  if nameOcc tcNm == "GHC.Classes.IP" then a2 else t
+stripIP t = t
+
 -- | Do an inverse topological sorting of the let-bindings in a let-expression
 inverseTopSortLetBindings
   :: HasCallStack