Store configurations for known domains

Clash.hs

@@ -49,12 +49,12 @@ doHDL
 doHDL b src = do
   startTime <- Clock.getCurrentTime
   pd      <- primDirs b
-  (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <- generateBindings Auto pd ["."] [] (hdlKind b) src Nothing
+  (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <- generateBindings Auto pd ["."] [] (hdlKind b) src Nothing
   prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` reprs `deepseq` Clock.getCurrentTime
   let prepStartDiff = reportTimeDiff prepTime startTime
   putStrLn $ "Loading dependencies took " ++ prepStartDiff
 
-  generateHDL (buildCustomReprs reprs) bindingsMap (Just b) primMap tcm tupTcm
+  generateHDL (buildCustomReprs reprs) domainConfs bindingsMap (Just b) primMap tcm tupTcm
     (ghcTypeToHWType WORD_SIZE_IN_BITS True) evaluator topEntities Nothing
     defClashOpts{opt_cachehdl = False, opt_dbgLevel = DebugSilent}
     (startTime,prepTime)

benchmark/common/BenchmarkCommon.hs

@@ -69,7 +69,7 @@ runInputStage
         )
 runInputStage idirs src = do
   pds <- primDirs backend
-  (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <- generateBindings Auto pds idirs [] (hdlKind backend) src Nothing
+  (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,_domainConfs) <- generateBindings Auto pds idirs [] (hdlKind backend) src Nothing
   let topEntityNames = map topId topEntities
       tm = head topEntityNames
   return (bindingsMap,tcm,tupTcm,topEntities, primMap, buildCustomReprs reprs, topEntityNames,tm)

changelog/2020-06-25T12_58_36+02_00_store_domain_configurations

@@ -0,0 +1,3 @@
+CHANGED: Clash now creates a mapping from domain names to configurations in LoadModules.
+See https://github.com/clash-lang/issues/968 for more information.
+

clash-ghc/src-bin-8.10/Clash/GHCi/UI.hs

@@ -2216,7 +2216,7 @@ makeHDL backend optsRef srcs = do
               forM_ srcs $ \src -> do
                 -- Generate bindings:
                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]
-                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-
+                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-
                   generateBindings color primDirs idirs dbs hdl src (Just dflags)
 
                 let getMain = getMainTopEntity src bindingsMap topEntities
@@ -2228,6 +2228,7 @@ makeHDL backend optsRef srcs = do
                 -- Generate HDL:
                 Clash.Driver.generateHDL
                   (buildCustomReprs reprs)
+                  domainConfs
                   bindingsMap
                   (Just backend')
                   primMap

clash-ghc/src-bin-841/Clash/GHCi/UI.hs

@@ -1998,7 +1998,7 @@ makeHDL backend optsRef srcs = do
               forM_ srcs $ \src -> do
                 -- Generate bindings:
                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]
-                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-
+                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-
                   generateBindings color primDirs idirs dbs hdl src (Just dflags)
                 let getMain = getMainTopEntity src bindingsMap topEntities
                 mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)
@@ -2009,6 +2009,7 @@ makeHDL backend optsRef srcs = do
                 -- Generate HDL:
                 Clash.Driver.generateHDL
                   (buildCustomReprs reprs)
+                  domainConfs
                   bindingsMap
                   (Just backend')
                   primMap

clash-ghc/src-bin-861/Clash/GHCi/UI.hs

@@ -2047,7 +2047,7 @@ makeHDL backend optsRef srcs = do
               forM_ srcs $ \src -> do
                 -- Generate bindings:
                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]
-                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-
+                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-
                   generateBindings color primDirs idirs dbs hdl src (Just dflags)
                 let getMain = getMainTopEntity src bindingsMap topEntities
                 mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)
@@ -2058,6 +2058,7 @@ makeHDL backend optsRef srcs = do
                 -- Generate HDL:
                 Clash.Driver.generateHDL
                   (buildCustomReprs reprs)
+                  domainConfs
                   bindingsMap
                   (Just backend')
                   primMap

clash-ghc/src-bin-881/Clash/GHCi/UI.hs

@@ -2138,7 +2138,7 @@ makeHDL backend optsRef srcs = do
               forM_ srcs $ \src -> do
                 -- Generate bindings:
                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]
-                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-
+                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-
                   generateBindings color primDirs idirs dbs hdl src (Just dflags)
 
                 let getMain = getMainTopEntity src bindingsMap topEntities
@@ -2150,6 +2150,7 @@ makeHDL backend optsRef srcs = do
                 -- Generate HDL:
                 Clash.Driver.generateHDL
                   (buildCustomReprs reprs)
+                  domainConfs
                   bindingsMap
                   (Just backend')
                   primMap

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

@@ -43,6 +43,7 @@ import qualified SrcLoc                  as GHC
 
 import           Clash.Annotations.BitRepresentation.Internal (DataRepr')
 import           Clash.Annotations.Primitive (HDL, extractPrim)
+import           Clash.Signal.Internal
 
 import           Clash.Core.Subst        (extendGblSubstList, mkSubst, substTm)
 import           Clash.Core.Term         (Term (..), mkLams, mkTyLams)
@@ -94,6 +95,7 @@ generateBindings
         , [TopEntityT]
         , CompiledPrimMap  -- The primitives found in '.' and 'primDir'
         , [DataRepr']
+        , HashMap.HashMap Text.Text VDomainConfiguration
         )
 generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do
   (  bindings
@@ -103,7 +105,8 @@ generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do
    , topEntities
    , partitionEithers -> (unresolvedPrims, pFP)
    , customBitRepresentations
-   , primGuards ) <- loadModules useColor hdl modName dflagsM importDirs
+   , primGuards
+   , domainConfs ) <- loadModules useColor hdl modName dflagsM importDirs
   primMapR <- generatePrimMap unresolvedPrims primGuards (concat [pFP, primDirs, importDirs])
   tdir <- maybe ghcLibDir (pure . GHC.topDir) dflagsM
   startTime <- Clock.getCurrentTime
@@ -145,6 +148,7 @@ generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do
          , topEntities''
          , primMapC
          , customBitRepresentations
+         , domainConfs
          )
 
 mkBindings

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

@@ -43,12 +43,16 @@ import           Control.Monad.IO.Class          (liftIO)
 import           Data.Char                       (isDigit)
 import           Data.Generics.Uniplate.DataOnly (transform)
 import           Data.Data                       (Data)
+import           Data.HashMap.Strict             (HashMap)
+import qualified Data.HashMap.Strict             as HashMap
 import           Data.Typeable                   (Typeable)
 import           Data.List                       (foldl', nub)
 import           Data.Maybe                      (catMaybes, listToMaybe, fromMaybe)
 import qualified Data.Text                       as Text
+import qualified Data.Text.Encoding              as Text
 import qualified Data.Time.Clock                 as Clock
 import           Language.Haskell.TH.Syntax      (lift)
+import           GHC.Natural                     (naturalFromInteger)
 import           GHC.Stack                       (HasCallStack)
 
 #ifdef USE_GHC_PATHS
@@ -65,13 +69,15 @@ import           System.Process                  (runInteractiveCommand,
 import qualified Annotations
 import qualified CoreFVs
 import qualified CoreSyn
+import qualified DataCon
 import qualified Digraph
 #if MIN_VERSION_ghc(8,6,0)
 import qualified DynamicLoading
 #endif
 import           DynFlags                        (GeneralFlag (..))
 import qualified DynFlags
 import qualified Exception
+import qualified FastString
 import qualified GHC
 import qualified HscMain
 import qualified HscTypes
@@ -81,6 +87,8 @@ import qualified GhcPlugins                      (deserializeWithData, installed
 import qualified TcRnMonad
 import qualified TcRnTypes
 import qualified TidyPgm
+import qualified TyCon
+import qualified Type
 import qualified Unique
 import qualified UniqFM
 import qualified FamInst
@@ -105,6 +113,8 @@ import           Clash.Util                                   (curLoc, noSrcSpan
 import           Clash.Annotations.BitRepresentation.Internal
   (DataRepr', dataReprAnnToDataRepr')
 
+import           Clash.Signal.Internal
+
 ghcLibDir :: IO FilePath
 #ifdef USE_GHC_PATHS
 ghcLibDir = return libdir
@@ -327,6 +337,7 @@ loadModules
         , [Either UnresolvedPrimitive FilePath]
         , [DataRepr']
         , [(Text.Text, PrimitiveGuard ())]
+        , HashMap Text.Text VDomainConfiguration -- domain names to configuration
         )
 loadModules useColor hdl modName dflagsM idirs = do
   libDir <- MonadUtils.liftIO ghcLibDir
@@ -379,7 +390,8 @@ loadModules useColor hdl modName dflagsM idirs = do
     reprs'     <- findCustomReprAnnotations
     primGuards <- findPrimitiveGuardAnnotations allBinderIds
     let topEntityName = fromMaybe "topEntity" (GHC.mainFunIs =<< dflagsM)
-        varNameString = OccName.occNameString . Name.nameOccName . Var.varName
+        nameString    = OccName.occNameString . Name.nameOccName
+        varNameString = nameString . Var.varName
         topEntities = filter ((==topEntityName) . varNameString) rootIds
         benches     = filter ((== "testBench") . varNameString) rootIds
         mergeBench (x,y) = (x,y,lookup x benchAnn)
@@ -429,16 +441,89 @@ loadModules useColor hdl modName dflagsM idirs = do
     let annExtDiff = reportTimeDiff annTime extTime
     MonadUtils.liftIO $ putStrLn $ "GHC: Parsing annotations took: " ++ annExtDiff
 
+    let famInstEnvs' = (fst famInstEnvs, modFamInstEnvs)
+        allTCInsts   = FamInstEnv.famInstEnvElts (fst famInstEnvs')
+                         ++ FamInstEnv.famInstEnvElts (snd famInstEnvs')
+
+        knownConfs   = filter (\x -> "KnownConf" == nameString (FamInstEnv.fi_fam x)) allTCInsts
+
+#if MIN_VERSION_ghc(8,10,0)
+        fsToText     = Text.decodeUtf8 . FastString.bytesFS
+#else
+        fsToText     = Text.decodeUtf8 . FastString.fastStringToByteString
+#endif
+
+        famToDomain  = fromMaybe (error "KnownConf: Expected Symbol at LHS of type family")
+                         . fmap fsToText . Type.isStrLitTy . head . FamInstEnv.fi_tys
+        famToConf    = unpackKnownConf . FamInstEnv.fi_rhs
+
+        knownConfNms = fmap famToDomain knownConfs
+        knownConfDs  = fmap famToConf knownConfs
+
+        knownConfMap = HashMap.fromList (zip knownConfNms knownConfDs)
+
     return ( allBinders
            , lbClassOps
            , lbUnlocatable
-           , (fst famInstEnvs, modFamInstEnvs)
+           , famInstEnvs'
            , topEntities'
            , lbPrims
            , reprs1
            , primGuards
+           , knownConfMap
            )
 
+-- | Given a type that represents the RHS of a KnownConf type family instance,
+-- unpack the fields of the DomainConfguration and make a VDomainConfiguration.
+--
+unpackKnownConf :: Type.Type -> VDomainConfiguration
+unpackKnownConf ty
+  | [d,p,ae,rk,ib,rp] <- Type.tyConAppArgs ty
+    -- Domain name
+  , Just dom <- fmap FastString.unpackFS (Type.isStrLitTy d)
+    -- Period
+  , Just period <- fmap naturalFromInteger (Type.isNumLitTy p)
+    -- Active Edge
+  , aeTc <- Type.tyConAppTyCon ae
+  , Just aeDc <- TyCon.isPromotedDataCon_maybe aeTc
+  , aeNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName aeDc)
+    -- Reset Kind
+  , rkTc <- Type.tyConAppTyCon rk
+  , Just rkDc <- TyCon.isPromotedDataCon_maybe rkTc
+  , rkNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName rkDc)
+    -- Init Behaviour
+  , ibTc <- Type.tyConAppTyCon ib
+  , Just ibDc <- TyCon.isPromotedDataCon_maybe ibTc
+  , ibNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName ibDc)
+    -- Reset Polarity
+  , rpTc <- Type.tyConAppTyCon rp
+  , Just rpDc <- TyCon.isPromotedDataCon_maybe rpTc
+  , rpNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName rpDc)
+  = VDomainConfiguration dom period
+      (asActiveEdge aeNm)
+      (asResetKind rkNm)
+      (asInitBehaviour ibNm)
+      (asResetPolarity rpNm)
+
+  | otherwise
+  = error $ $(curLoc) ++ "Could not unpack domain configuration."
+ where
+  asActiveEdge "Rising"  = Rising
+  asActiveEdge "Falling" = Falling
+  asActiveEdge x = error $ $(curLoc) ++ "Unknown active edge: " ++ show x
+
+  asResetKind "Synchronous"  = Synchronous
+  asResetKind "Asynchronous" = Asynchronous
+  asResetKind x = error $ $(curLoc) ++ "Unknown reset kind: " ++ show x
+
+  asInitBehaviour "Unknown" = Unknown
+  asInitBehaviour "Defined" = Defined
+  asInitBehaviour x = error $ $(curLoc) ++ "Unknown init behaviour: " ++ show x
+
+  asResetPolarity "ActiveHigh" = ActiveHigh
+  asResetPolarity "ActiveLow"  = ActiveLow
+  asResetPolarity x = error $ $(curLoc) ++ "Unknown reset polarity: " ++ show x
+
 -- | Given a set of bindings, make explicit non-recursive bindings and
 -- recursive binding groups.
 --

clash-lib/src/Clash/Driver.hs

@@ -105,6 +105,7 @@ import qualified Clash.Primitives.Intel.ClockGen  as P
 import qualified Clash.Primitives.Verification    as P
 import           Clash.Primitives.Types
 import           Clash.Primitives.Util            (hashCompiledPrimMap)
+import           Clash.Signal.Internal
 import           Clash.Unique                     (keysUniqMap, lookupUniqMap')
 import           Clash.Util.Interpolate           (i)
 import           Clash.Util
@@ -211,6 +212,8 @@ getClashModificationDate = Directory.getModificationTime =<< getExecutablePath
 generateHDL
   :: forall backend . Backend backend
   => CustomReprs
+  -> HashMap Data.Text.Text VDomainConfiguration
+  -- ^ Known domains to configurations
   -> BindingMap
   -- ^ Set of functions
   -> Maybe backend
@@ -234,7 +237,7 @@ generateHDL
   -- ^ Debug information level for the normalization process
   -> (Clock.UTCTime,Clock.UTCTime)
   -> IO ()
-generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
+generateHDL reprs domainConfs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
   topEntities0 mainTopEntity opts (startTime,prepTime) =
     let todo = maybe topEntities2 (uncurry (:)) mainTopEntity in
     go prepTime HashMap.empty (sortTop bindingsMap todo)
@@ -415,7 +418,7 @@ generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
 
       -- 3. Generate topEntity wrapper
       let topComponent = view _4 . head $ filter (Data.Text.isSuffixOf topNm . componentName . view _4) netlist
-          (hdlDocs,manifest',dfiles,mfiles)  = createHDL hdlState' (Data.Text.pack modName) seen' netlist topComponent
+          (hdlDocs,manifest',dfiles,mfiles)  = createHDL hdlState' (Data.Text.pack modName) seen' netlist domainConfs topComponent
                                    (topNm, Right manifest)
       mapM_ (writeHDL dir) hdlDocs
       copyDataFiles (opt_importPaths opts) dir dfiles
@@ -454,7 +457,7 @@ generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
       putStrLn $ "Clash: Testbench netlist generation took " ++ normNetDiff
 
       -- 3. Write HDL
-      let (hdlDocs,_,dfiles,mfiles) = createHDL hdlState2 modName' seen'' netlist undefined
+      let (hdlDocs,_,dfiles,mfiles) = createHDL hdlState2 modName' seen'' netlist domainConfs undefined
                            (topNm, Left manifest')
       writeHDL (hdlDir </> maybe "" t_name annM) (head hdlDocs)
       mapM_ (writeHDL dir) (tail hdlDocs)
@@ -715,6 +718,8 @@ createHDL
   -- ^ Component names
   -> [([Bool],SrcSpan,HashMap Identifier Word,Component)]
   -- ^ List of components
+  -> HashMap Data.Text.Text VDomainConfiguration
+  -- ^ Known domains to configurations
   -> Component
   -- ^ Top component
   -> (Identifier, Either Manifest Manifest)
@@ -726,7 +731,7 @@ createHDL
   -- ^ The pretty-printed HDL documents
   -- + The update manifest file
   -- + The data files that need to be copied
-createHDL backend modName seen components top (topName,manifestE) = flip evalState backend $ getMon $ do
+createHDL backend modName seen components _domainConfs top (topName,manifestE) = flip evalState backend $ getMon $ do
   (hdlNmDocs,incs) <- unzip <$> mapM (\(_wereVoids,sp,ids,comp) -> genHDL modName sp (HashMap.unionWith max seen ids) comp) components
   hwtys <- HashSet.toList <$> extractTypes <$> Mon get
   typesPkg <- mkTyPackage modName hwtys

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

@@ -55,7 +55,7 @@ runToCoreStage
   -> IO (BindingMap, TyConMap)
 runToCoreStage target f src = do
   pds <- primDirs backend
-  (bm, tcm, _, _, _, _) <- generateBindings
+  (bm, tcm, _, _, _, _, _) <- generateBindings
     Auto pds (opt_importPaths opts) [] (hdlKind backend) src Nothing
 
   return (bm, tcm)

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

@@ -89,7 +89,7 @@ runToNetlistStage
   -> IO [([Bool], SrcSpan, HashMap Identifier Word, Component)]
 runToNetlistStage target f src = do
   pds <- primDirs backend
-  (bm, tcm, tupTcm, tes, pm, rs)
+  (bm, tcm, tupTcm, tes, pm, rs, _)
     <- generateBindings Auto pds (opt_importPaths opts) [] (hdlKind backend) src Nothing
 
   let teNames = fmap topId tes