Refactor topentity triple to 'TopEntityT'

Author: martijnbastiaan

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/Driver.hs

@@ -77,7 +77,8 @@ import           Clash.Netlist.Util               (genComponentName, genTopCompo
 import           Clash.Netlist.BlackBox.Parser    (runParse)
 import           Clash.Netlist.BlackBox.Types     (BlackBoxTemplate, BlackBoxFunction)
 import           Clash.Netlist.Types
-  (BlackBox (..), Component (..), Identifier, FilteredHWType, HWMap, SomeBackend (..))
+  (BlackBox (..), Component (..), Identifier, FilteredHWType, HWMap,
+   SomeBackend (..), TopEntityT(..))
 import           Clash.Normalize                  (checkNonRecursive, cleanupGraph,
                                                    normalize, runNormalization)
 import           Clash.Normalize.Util             (callGraph)
@@ -109,13 +110,8 @@ generateHDL
   -- ^ Hardcoded 'Type' -> 'HWType' translator
   -> (PrimStep, PrimUnwind)
   -- ^ Hardcoded evaluator (delta-reduction)
-  -> [( Id
-      , Maybe TopEntity
-      , Maybe Id
-      )]
-  -- ^ topEntity bndr
-  -- + (maybe) TopEntity annotation
-  -- + (maybe) testBench bndr
+  -> [TopEntityT]
+  -- ^ Topentities and associated testbench
   -> ClashOpts
   -- ^ Debug information level for the normalization process
   -> (Clock.UTCTime,Clock.UTCTime)
@@ -128,7 +124,7 @@ generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
                                 reportTimeDiff prevTime startTime
 
   -- Process the next TopEntity
-  go prevTime seen ((topEntity,annM,benchM):topEntities') = do
+  go prevTime seen (TopEntityT topEntity annM benchM:topEntities') = do
   let topEntityS = Data.Text.unpack (nameOcc (varName topEntity))
   putStrLn $ "Clash: Compiling " ++ topEntityS
 
@@ -259,7 +255,7 @@ generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
                     . snd
                     . Supply.freshId
                    <$> Supply.newSupply
-  let topEntityNames = map (\(x,_,_) -> x) topEntities
+  let topEntityNames = map topId topEntities
 
   (topTime,manifest',seen') <- if useCacheTop
     then do
@@ -705,32 +701,23 @@ normalizeEntity reprs bindingsMap primMap tcm tupTcm typeTrans eval topEntities
 -- | topologically sort the top entities
 sortTop
   :: BindingMap
-  -> [( Id
-      , Maybe TopEntity
-      , Maybe Id
-      )]
-  -- ^ topEntity bndr
-  -- + (maybe) TopEntity annotation
-  -- + (maybe) testBench bndr
-  -> [( Id
-      , Maybe TopEntity
-      , Maybe Id
-      )]
-  -- ^ topEntity bndr
-  -- + (maybe) TopEntity annotation
-  -- + (maybe) testBench bndr
+  -> [TopEntityT]
+  -> [TopEntityT]
 sortTop bindingsMap topEntities =
   let (nodes,edges) = unzip (map go topEntities)
   in  case reverseTopSort nodes (concat edges) of
         Left msg   -> error msg
         Right tops -> tops
  where
-  go t@(topE,_,tbM) =
+  go t@(TopEntityT topE _ tbM) =
     let topRefs = goRefs topE topE
         tbRefs  = maybe [] (goRefs topE) tbM
     in  ((varUniq topE,t)
-         ,map ((\(v,_,_) -> (varUniq topE, varUniq v))) (tbRefs ++ topRefs))
+         ,map ((\top -> (varUniq topE, varUniq (topId top)))) (tbRefs ++ topRefs))
 
   goRefs top i =
     let cg = callGraph bindingsMap i
-    in  filter (\(v,_,_) -> v /= top && v /= i && v `elemVarEnv` cg) topEntities
+    in
+      filter
+        (\t -> topId t /= top && topId t /= i && topId t `elemVarEnv` cg)
+        topEntities

clash-lib/src/Clash/Netlist.hs

@@ -85,7 +85,7 @@ genNetlist
   -- ^ Custom bit representations for certain types
   -> BindingMap
   -- ^ Global binders
-  -> [(Id,Maybe TopEntity,Maybe Id)]
+  -> [TopEntityT]
   -- ^ All the TopEntities
   -> CompiledPrimMap
   -- ^ Primitive definitions
@@ -114,17 +114,15 @@ genNetlist
   -- ^ Name of the @topEntity@
   -> IO ([([Bool],SrcSpan,HashMap Identifier Word,Component)],HashMap Identifier Word)
 genNetlist isTb opts reprs globals tops primMap tcm typeTrans iw mkId extId ite be seen env prefixM topEntity = do
-  (_,s) <- runNetlistMonad isTb opts reprs globals (mkTopEntityMap tops)
+  (_,s) <- runNetlistMonad isTb opts reprs globals topEntityMap
              primMap tcm typeTrans iw mkId extId ite be seen env prefixM $
              genComponent topEntity
   return ( eltsVarEnv $ _components s
          , _seenComps s
          )
   where
-    mkTopEntityMap
-      :: [(Id,Maybe TopEntity,Maybe Id)]
-      -> VarEnv (Type,Maybe TopEntity)
-    mkTopEntityMap = mkVarEnv . map (\(a,b,_) -> (a,(varType a,b)))
+    topEntityMap :: VarEnv TopEntityT
+    topEntityMap = mkVarEnv (zip (map topId tops) tops)
 
 -- | Run a NetlistMonad action in a given environment
 runNetlistMonad
@@ -136,7 +134,7 @@ runNetlistMonad
   -- ^ Custom bit representations for certain types
   -> BindingMap
   -- ^ Global binders
-  -> VarEnv (Type, Maybe TopEntity)
+  -> VarEnv TopEntityT
   -- ^ TopEntity annotations
   -> CompiledPrimMap
   -- ^ Primitive Definitions
@@ -219,7 +217,7 @@ genComponentT
 genComponentT compName componentExpr = do
   varCount .= 0
   componentName1 <- (`lookupVarEnv'` compName) <$> Lens.use componentNames
-  topEntMM <- fmap snd . lookupVarEnv compName <$> Lens.use topEntityAnns
+  topEntMM <- fmap topAnnotation . lookupVarEnv compName <$> Lens.use topEntityAnns
   prefixM <- Lens.use componentPrefix
   let componentName2 = case (prefixM,join topEntMM) of
                          ((Just p,_),Just ann) -> p `StrictText.append` StrictText.pack ('_':t_name ann)
@@ -233,8 +231,8 @@ genComponentT compName componentExpr = do
   -- HACK: Determine resulttype of this function by looking at its definition
   -- in topEntityAnns, instead of looking at its last binder (which obscure
   -- any attributes [see: Clash.Annotations.SynthesisAttributes]).
-  topEntityTypeM     <- lookupVarEnv compName <$> Lens.use topEntityAnns
-  let topEntityTypeM' = snd . splitCoreFunForallTy tcm . fst <$> topEntityTypeM
+  topEntityTypeM <- lookupVarEnv compName <$> Lens.use topEntityAnns
+  let topEntityTypeM' = snd . splitCoreFunForallTy tcm . varType . topId <$> topEntityTypeM
 
   seenIds .= HashMapS.empty
   (wereVoids,compInps,argWrappers,compOutps,resUnwrappers,binders,resultM) <-
@@ -564,13 +562,15 @@ mkFunApp dstId fun args tickDecls = do
   topAnns <- Lens.use topEntityAnns
   tcm     <- Lens.use tcCache
   case lookupVarEnv fun topAnns of
-    Just (ty,annM)
-      | let (fArgTys0,fResTy) = splitFunTys tcm ty
+    Just topEntity
+      | let ty = varType (topId topEntity)
+      , let (fArgTys0,fResTy) = splitFunTys tcm ty
       -- Take into account that clocks and stuff are split off from any product
       -- types containing them
       , let fArgTys1 = splitShouldSplit tcm fArgTys0
       , length fArgTys1 == length args
       -> do
+        let annM = topAnnotation topEntity
         argHWTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) fArgTys1
         (argExprs, concat -> argDecls) <- unzip <$>
           mapM (\(e,t) -> mkExpr False Concurrent (NetlistId dstId t) e)

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

@@ -68,6 +68,17 @@ import Clash.Util                           (HasCallStack, makeLenses)
 import Clash.Annotations.BitRepresentation.Internal
   (CustomReprs, DataRepr', ConstrRepr')
 
+-- | Structure describing a top entity: it's id, its port annotations, and
+-- associated testbench.
+data TopEntityT = TopEntityT
+  { topId :: Id
+  -- ^ Id of top entity
+  , topAnnotation :: Maybe TopEntity
+  -- ^ (Maybe) a topentity annotation
+  , associatedTestbench :: Maybe Id
+  -- ^ (Maybe) a test bench associated with the topentity
+  } deriving (Generic)
+
 -- | Monad that caches generated components (StateT) and remembers hidden inputs
 -- of components that are being generated (WriterT)
 newtype NetlistMonad a =
@@ -115,7 +126,7 @@ data NetlistState
   -- filter duplicate warning invocations for dubious blackbox instantiations,
   -- see GitHub pull request #286.
   , _componentNames :: VarEnv Identifier
-  , _topEntityAnns  :: VarEnv (Type, Maybe TopEntity)
+  , _topEntityAnns  :: VarEnv TopEntityT
   , _hdlDir         :: FilePath
   , _curBBlvl       :: Int
   -- ^ The current scoping level assigned to black box contexts

testsuite/src/Test/Tasty/Clash/NetlistTest.hs

@@ -92,8 +92,8 @@ runToNetlistStage target f src = do
   (bm, tcm, tupTcm, tes, pm, rs)
     <- generateBindings Auto pds (opt_importPaths opts) [] (hdlKind backend) src Nothing
 
-  let teNames = fmap fstTriple tes
-      te      = fstTriple (P.head tes)
+  let teNames = fmap topId tes
+      te      = topId (P.head tes)
       reprs   = buildCustomReprs rs
 
   supplyN <- Supply.newSupply
@@ -106,8 +106,6 @@ runToNetlistStage target f src = do
   backend = mkBackend target
   opts = f mkClashOpts
 
-  fstTriple (x, _, _) = x
-
   netlistFrom (bm, tcm, tes, pm, rs, te) =
     genNetlist False opts rs bm tes pm tcm typeTrans
       iw mkId1 extId ite (SomeBackend hdlSt) seen hdlDir prefixM te