[skip ci] Implement synthesis domains in compiler

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

@@ -627,8 +627,10 @@ wantedLanguageExtensions df =
              , LangExt.ExplicitForAll
              , LangExt.ExplicitNamespaces
              , LangExt.FlexibleContexts
+             , LangExt.FlexibleInstances
              , LangExt.KindSignatures
              , LangExt.MagicHash
+             , LangExt.MultiParamTypeClasses
              , LangExt.MonoLocalBinds
              , LangExt.QuasiQuotes
              , LangExt.ScopedTypeVariables

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

@@ -19,18 +19,21 @@ import Data.Functor.Identity            (Identity (..))
 import Data.Text                        (pack)
 import Control.Monad.Trans.Except
   (ExceptT (..), mapExceptT, runExceptT, throwE)
+import Language.Haskell.TH.Syntax       (showName)
 
 import Clash.Core.DataCon               (DataCon (..))
 import Clash.Core.Name                  (Name (..))
 import Clash.Core.Pretty                (showPpr)
 import Clash.Core.TyCon                 (TyConMap, tyConDataCons)
 import Clash.Core.Type
-  (LitTy (..), Type (..), TypeView (..), coreView1, tyView)
+  (LitTy (..), Type (..), TypeView (..), coreView, tyView)
 import Clash.Core.Util                  (tyNatSize)
 import Clash.Netlist.Util               (coreTypeToHWType, stripFiltered)
 import Clash.Netlist.Types
   (HWType(..), FilteredHWType(..), PortDirection (..))
-import Clash.Signal.Internal            (ClockKind (..), ResetKind (..))
+import Clash.Signal.Internal
+  (ResetPolarity(..), ActiveEdge(..), ResetKind(..)
+  ,InitBehavior(..))
 import Clash.Unique                     (lookupUniqMap')
 import Clash.Util                       (curLoc)
 
@@ -128,17 +131,34 @@ ghcTypeToHWType iw floatSupport = go
           (fType . Void . Just . BiDirectional Out . BitVector . fromInteger) <$>
             mapExceptT (Just .coerce) (tyNatSize m szTy)
 
+        "Clash.Signal.Internal.KnownDomain"
+          | [_tag, dom] <- args
+          ->
+            case tyView dom of
+              TyConApp _ [tag0, period0, edge0, rstKind0, init0, polarity0] -> do
+                tag1      <- domTag tag0
+                period1   <- domPeriod period0
+                edge1     <- domEdge m edge0
+                rstKind1  <- domResetKind m rstKind0
+                init1     <- domInitBehavior m init0
+                polarity1 <- domResetPolarity m polarity0
+
+                let kd = KnownDomain (pack tag1) period1 edge1 rstKind1 init1 polarity1
+                returnN (Void (Just kd))
+              _ ->
+                ExceptT Nothing
+
         "Clash.Signal.Internal.Clock"
-          | [dom,clkKind] <- args
-          -> do (nm,rate) <- domain m dom
-                gated     <- clockKind m clkKind
-                returnN (Clock (pack nm) rate gated)
+          | [tag0] <- args
+          -> do
+            tag1 <- domTag tag0
+            returnN (Clock (pack tag1))
 
         "Clash.Signal.Internal.Reset"
-          | [dom,rstKind] <- args
-          -> do (nm,rate)   <- domain m dom
-                synchronous <- resetKind m rstKind
-                returnN (Reset (pack nm) rate synchronous)
+          | [tag0] <- args
+          -> do
+            tag1 <- domTag tag0
+            returnN (Reset (pack tag1))
 
         "Clash.Sized.Internal.BitVector.Bit" -> returnN Bit
 
@@ -214,37 +234,76 @@ ghcTypeToHWType iw floatSupport = go
 
     go _ _ _ = Nothing
 
-domain
-  :: TyConMap
+domTag :: Type -> ExceptT String Maybe String
+domTag (LitTy (SymTy tag)) = pure tag
+domTag ty = throwE $ "Can't translate domain tag" ++ showPpr ty
+
+domPeriod :: Type -> ExceptT String Maybe Integer
+domPeriod (LitTy (NumTy period)) = pure period
+domPeriod ty = throwE $ "Can't translate domain period" ++ showPpr ty
+
+
+fromType
+  :: String
+  -- ^ Name of type (for error reporting)
+  -> [(String, a)]
+  -- ^ [(Fully qualified constructor name, constructor value)
+  -> TyConMap
+  -- ^ Constructor map (used to look through newtypes)
   -> Type
-  -> ExceptT String Maybe (String,Integer)
-domain m (coreView1 m -> Just ty') = domain m ty'
-domain m (tyView -> TyConApp tcNm [LitTy (SymTy nm),rateTy])
-  | nameOcc tcNm == "Clash.Signal.Internal.Dom"
-  = do rate <- mapExceptT (Just . coerce) (tyNatSize m rateTy)
-       return (nm,rate)
-domain _ ty = throwE $ "Can't translate domain: " ++ showPpr ty
-
-clockKind
+  -- ^ Type representing some constructor
+  -> ExceptT String Maybe a
+fromType tyNm constrs m ty =
+  case tyView (coreView m ty) of
+    TyConApp tcNm [] ->
+      go constrs (nameOcc tcNm)
+    _ ->
+      throwE $ "Can't translate " ++ tyNm ++ showPpr ty
+ where
+  go ((cName,c):cs) tcNm =
+    if pack cName == tcNm then
+      pure c
+    else
+      go cs tcNm
+  go [] _ =
+    throwE $ "Can't translate " ++ tyNm ++ showPpr ty
+
+domEdge
   :: TyConMap
   -> Type
-  -> ExceptT String Maybe ClockKind
-clockKind m (coreView1 m -> Just ty') = clockKind m ty'
-clockKind _ (tyView -> TyConApp tcNm [])
-  | nameOcc tcNm == "Clash.Signal.Internal.Source"
-  = return Source
-  | nameOcc tcNm == "Clash.Signal.Internal.Gated"
-  = return Gated
-clockKind _ ty = throwE $ "Can't translate ClockKind" ++ showPpr ty
-
-resetKind
+  -> ExceptT String Maybe ActiveEdge
+domEdge =
+  fromType
+    (showName ''ActiveEdge)
+    [ (showName 'Rising, Rising)
+    , (showName 'Falling, Falling) ]
+
+domResetKind
   :: TyConMap
   -> Type
   -> ExceptT String Maybe ResetKind
-resetKind m (coreView1 m -> Just ty') = resetKind m ty'
-resetKind _ (tyView -> TyConApp tcNm [])
-  | nameOcc tcNm == "Clash.Signal.Internal.Synchronous"
-  = return Synchronous
-  | nameOcc tcNm == "Clash.Signal.Internal.Asynchronous"
-  = return Asynchronous
-resetKind _ ty = throwE $ "Can't translate ResetKind" ++ showPpr ty
+domResetKind =
+  fromType
+    (showName ''ResetKind)
+    [ (showName 'Synchronous, Synchronous)
+    , (showName 'Asynchronous, Asynchronous) ]
+
+domInitBehavior
+  :: TyConMap
+  -> Type
+  -> ExceptT String Maybe InitBehavior
+domInitBehavior =
+  fromType
+    (showName ''InitBehavior)
+    [ (showName 'Defined, Defined)
+    , (showName 'Undefined, Undefined) ]
+
+domResetPolarity
+  :: TyConMap
+  -> Type
+  -> ExceptT String Maybe ResetPolarity
+domResetPolarity =
+  fromType
+    (showName ''ResetPolarity)
+    [ (showName 'ActiveHigh, ActiveHigh)
+    , (showName 'ActiveLow, ActiveLow) ]

clash-lib/src/Clash/Backend/SystemVerilog.hs

@@ -58,7 +58,6 @@ import           Clash.Netlist.BlackBox.Util
 import           Clash.Netlist.Id                     (IdType (..), mkBasicId')
 import           Clash.Netlist.Types                  hiding (_intWidth, intWidth)
 import           Clash.Netlist.Util                   hiding (mkIdentifier, extendIdentifier)
-import           Clash.Signal.Internal                (ClockKind (..))
 import           Clash.Util
   (SrcSpan, noSrcSpan, curLoc, makeCached, (<:>), first, on, traceIf)
 import           Clash.Util.Graph                     (reverseTopSort)
@@ -313,7 +312,6 @@ mkUsedTys v@(Vector _ elTy)     = v : mkUsedTys elTy
 mkUsedTys t@(RTree _ elTy)      = t : mkUsedTys elTy
 mkUsedTys p@(Product _ _ elTys) = p : concatMap mkUsedTys elTys
 mkUsedTys sp@(SP _ elTys)       = sp : concatMap mkUsedTys (concatMap snd elTys)
-mkUsedTys c@(Clock _ _ Gated)   = [c,Bit,Bool]
 mkUsedTys t                     = [t]
 
 topSortHWTys :: [HWType]
@@ -352,9 +350,7 @@ normaliseType (CustomSP _ _dataRepr size elTys) = do
 normaliseType ty@(Index _) = return (Unsigned (typeSize ty))
 normaliseType ty@(Sum _ _) = return (BitVector (typeSize ty))
 normaliseType ty@(CustomSum _ _ _ _) = return (BitVector (typeSize ty))
-normaliseType ty@(Clock _ _ Gated) =
-  return (gatedClockType ty)
-normaliseType (Clock _ _ Source) = return Bit
+normaliseType (Clock _) = return Bit
 normaliseType (Reset {}) = return Bit
 normaliseType (BiDirectional dir ty) = BiDirectional dir <$> normaliseType ty
 normaliseType ty = return ty
@@ -411,15 +407,6 @@ tyDec ty@(Product _ _ tys) | typeSize ty > 0 = Just A.<$> prodDec
 
 tyDec _ = pure Nothing
 
-gatedClockType :: HWType -> HWType
-gatedClockType (Clock nm rt Gated) =
-  Product
-    ("GatedClock" `TextS.append` (TextS.pack (show (nm,rt))))
-    (Just ["clk", "enable"])
-    [Bit,Bool]
-gatedClockType ty = ty
-{-# INLINE gatedClockType #-}
-
 splitVecTy :: HWType -> Maybe ([Either Int Int],SystemVerilogM Doc)
 splitVecTy = fmap splitElemTy . go
   where
@@ -645,8 +632,7 @@ verilogType t_ = do
       nm <- Mon $ use modNm
       stringS nm <> "_types::" <> tyName t
     Signed n      -> logicOrWire <+> "signed" <+> brackets (int (n-1) <> colon <> int 0)
-    Clock _ _ Gated -> verilogType (gatedClockType t)
-    Clock _ _ Source-> "logic"
+    Clock _       -> "logic"
     Reset {}      -> "logic"
     Bit           -> "logic"
     Bool          -> "logic"
@@ -703,10 +689,9 @@ tyName t@(Product nm _ _)      = do
       in  if n' `elem` s
              then go mkId s (i+1) n
              else n'
-tyName t@(SP _ _)  = "logic_vector_" <> int (typeSize t)
-tyName t@(Clock _ _ Gated) = tyName (gatedClockType t)
-tyName (Clock _ _ Source)  = "logic"
-tyName (Reset {})  = "logic"
+tyName t@(SP _ _) = "logic_vector_" <> int (typeSize t)
+tyName (Clock _)  = "logic"
+tyName (Reset {}) = "logic"
 tyName t =  error $ $(curLoc) ++ "tyName: " ++ show t
 
 -- | Convert a Netlist HWType to an error SystemVerilog value for that type
@@ -950,10 +935,6 @@ expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ _ tys),_,fI)))) = do
   id'<- fmap (Text.toStrict . renderOneLine) (stringS id_ <> dot <> tyName ty <> "_sel" <> int fI)
   simpleFromSLV (tys !! fI) id'
 
-expr_ _ (Identifier id_ (Just (Indexed (ty@(Clock _ _ Gated),_,fI)))) = do
-  ty' <- normaliseType ty
-  stringS =<< fmap (Text.toStrict . renderOneLine) (stringS id_ <> dot <> tyName ty' <> "_sel" <> int fI)
-
 expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do
   id' <- fmap (Text.toStrict . renderOneLine) (stringS id_ <> brackets (int 0))
   simpleFromSLV elTy id'
@@ -1132,8 +1113,6 @@ expr_ _ (DataCon (CustomSP _ dataRepr size args) (DC (_,i)) es) =
                let rotated  = parens expr' <+> ">>" <+> int end in
                int fsize <> squote <> parens rotated
 expr_ _ (DataCon (Product _ _ tys) _ es) = listBraces (zipWithM toSLV tys es)
-expr_ _ (DataCon (Clock nm rt Gated) _ es) =
-  listBraces (zipWithM toSLV [Clock nm rt Source,Bool] es)
 
 expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)
   | pNm == "Clash.Sized.Internal.Signed.fromInteger#"