From c4da0ac4ac1c256faeb7b64334b2aa5e88eac452 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Fri, 14 Jun 2019 14:04:10 +0200 Subject: [PATCH] [skip ci] Implement synthesis domains in compiler --- clash-ghc/src-ghc/Clash/GHC/LoadModules.hs | 2 + clash-ghc/src-ghc/Clash/GHC/NetlistTypes.hs | 135 ++++++++++----- clash-lib/src/Clash/Backend/SystemVerilog.hs | 31 +--- clash-lib/src/Clash/Backend/VHDL.hs | 56 +++---- clash-lib/src/Clash/Backend/Verilog.hs | 27 +-- clash-lib/src/Clash/Netlist.hs | 15 +- clash-lib/src/Clash/Netlist/BlackBox.hs | 18 +- .../src/Clash/Netlist/BlackBox/Parser.hs | 11 +- clash-lib/src/Clash/Netlist/BlackBox/Types.hs | 15 +- clash-lib/src/Clash/Netlist/BlackBox/Util.hs | 156 +++++++++++++++--- clash-lib/src/Clash/Netlist/Types.hs | 54 +++--- clash-lib/src/Clash/Netlist/Util.hs | 126 +------------- 12 files changed, 342 insertions(+), 304 deletions(-) diff --git a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs b/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs index e6d4f862c2..d7bea04643 100644 --- a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs +++ b/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 diff --git a/clash-ghc/src-ghc/Clash/GHC/NetlistTypes.hs b/clash-ghc/src-ghc/Clash/GHC/NetlistTypes.hs index 469b7122af..52c35047eb 100644 --- a/clash-ghc/src-ghc/Clash/GHC/NetlistTypes.hs +++ b/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) ] diff --git a/clash-lib/src/Clash/Backend/SystemVerilog.hs b/clash-lib/src/Clash/Backend/SystemVerilog.hs index 9c04c83109..a36ca68ff8 100644 --- a/clash-lib/src/Clash/Backend/SystemVerilog.hs +++ b/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#" diff --git a/clash-lib/src/Clash/Backend/VHDL.hs b/clash-lib/src/Clash/Backend/VHDL.hs index dff5bbf86e..5102eff8c3 100644 --- a/clash-lib/src/Clash/Backend/VHDL.hs +++ b/clash-lib/src/Clash/Backend/VHDL.hs @@ -62,7 +62,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) -import Clash.Signal.Internal (ClockKind (..), ResetKind (..)) import Clash.Util (SrcSpan, noSrcSpan, clogBase, curLoc, first, makeCached, on, traceIf, (<:>)) import Clash.Util.Graph (reverseTopSort) @@ -402,7 +401,6 @@ mkUsedTys hwty = hwty : case hwty of CustomSP _ _ _ tys0 -> let tys1 = concat [tys | (_repr, _id, tys) <- tys0] in concatMap mkUsedTys tys1 - Clock _ _ Gated -> mkUsedTys (normaliseType hwty) _ -> [] @@ -452,9 +450,6 @@ topSortHWTys hwtys = sorted let tys2 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys1] in map (nodesI HashMap.! t,) (catMaybes tys2) - edge c@(Clock _ _ Gated) = - [(nodesI HashMap.! c, nodesI HashMap.! normaliseType c)] - edge _ = [] mkVecZ :: HWType -> HWType @@ -511,8 +506,8 @@ tyDec hwty = do "end record" <> semi -- Type aliases: - Clock _ _ _ -> typAliasDec hwty - Reset _ _ _ -> typAliasDec hwty + Clock _ -> typAliasDec hwty + Reset _ -> typAliasDec hwty Index _ -> typAliasDec hwty CustomSP _ _ _ _ -> typAliasDec hwty SP _ _ -> typAliasDec hwty @@ -533,6 +528,7 @@ tyDec hwty = do Annotated _ ty -> tyDec ty Void {} -> emptyDoc + KnownDomain {} -> emptyDoc _ -> error $ $(curLoc) ++ show hwty @@ -1021,8 +1017,10 @@ tyName' tyName' rec0 (filterTransparent -> t) = do Mon (tyCache %= HashSet.insert t) case t of + KnownDomain {} -> + return (error ($(curLoc) ++ "Forced to print KnownDomain tyName")) Void _ -> - return (error ($(curLoc) ++ "[CLASH BUG] Forced to print Void tyName")) + return (error ($(curLoc) ++ "Forced to print Void tyName")) Bool -> return "boolean" Signed n -> let app = if rec0 then ["_", showt n] else [] in @@ -1051,13 +1049,10 @@ tyName' rec0 (filterTransparent -> t) = do -- TODO: nice formatting for Index. I.e., 2000 = 2e3, 1024 = 2pow10 Index n -> return ("index_" `TextS.append` showt n) - Clock nm0 _ Gated -> - let nm1 = "clk_gated_" `TextS.append` nm0 in - Mon $ makeCached (t, False) nameCache (userTyName "clk_gated" nm1 t) - Clock nm0 _ Source -> + Clock nm0 -> let nm1 = "clk_" `TextS.append` nm0 in Mon $ makeCached (t, False) nameCache (userTyName "clk" nm1 t) - Reset nm0 _ _ -> + Reset nm0 -> let nm1 = "rst_" `TextS.append` nm0 in Mon $ makeCached (t, False) nameCache (userTyName "rst" nm1 t) Sum nm _ -> @@ -1080,6 +1075,7 @@ tyName' rec0 (filterTransparent -> t) = do normaliseType :: HWType -> HWType normaliseType hwty = case hwty of Void {} -> hwty + KnownDomain {} -> hwty -- Base types: Bool -> hwty @@ -1095,13 +1091,9 @@ normaliseType hwty = case hwty of RTree _ _ -> hwty Product _ _ _ -> hwty - -- Special case for gated clock, which is converted to a tuple: - Clock nm _ Gated -> - normaliseType (Product ("GatedClock_" `TextS.append` nm) (Just ["clk", "enable"]) [Bit, Bool]) - -- Simple types, for which a subtype (without qualifiers) will be made in VHDL: - Clock _ _ Source -> Bit - Reset _ _ _ -> Bit + Clock _ -> Bit + Reset _ -> Bit Index _ -> Unsigned (typeSize hwty) CustomSP _ _ _ _ -> BitVector (typeSize hwty) SP _ _ -> BitVector (typeSize hwty) @@ -1122,8 +1114,8 @@ filterTransparent hwty = case hwty of String -> hwty Integer -> hwty Bit -> hwty - Clock _ _ _ -> hwty - Reset _ _ _ -> hwty + Clock _ -> hwty + Reset _ -> hwty Index _ -> hwty Sum _ _ -> hwty CustomSum _ _ _ _ -> hwty @@ -1146,6 +1138,7 @@ filterTransparent hwty = case hwty of BiDirectional _ elTy -> elTy Void {} -> hwty + KnownDomain {} -> hwty -- | Create a unique type name for user defined types userTyName @@ -1191,10 +1184,9 @@ sizedQualTyNameErrValue t@(RTree n elTy) = do _ -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> sizedQualTyNameErrValue elTy) sizedQualTyNameErrValue t@(Product _ _ elTys) = qualTyName t <> "'" <> tupled (mapM sizedQualTyNameErrValue elTys) -sizedQualTyNameErrValue (Reset {}) = singularErrValue -sizedQualTyNameErrValue (Clock _ _ Source) = singularErrValue -sizedQualTyNameErrValue (Clock _ _ Gated) = tupled (sequence [singularErrValue,"false"]) -sizedQualTyNameErrValue (Void {}) = +sizedQualTyNameErrValue (Reset {}) = singularErrValue +sizedQualTyNameErrValue (Clock _) = singularErrValue +sizedQualTyNameErrValue (Void {}) = return (error ($(curLoc) ++ "[CLASH BUG] Forced to print Void error value")) sizedQualTyNameErrValue String = "\"ERROR\"" sizedQualTyNameErrValue t = @@ -1418,9 +1410,6 @@ expr_ b (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = do expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ labels tys),_,fI)))) = pretty id_ <> dot <> tyName ty <> selectProductField labels tys fI -expr_ p (Identifier id_ (Just (Indexed (ty@(Clock _ _ Gated),x,fI)))) = do - expr_ p (Identifier id_ (Just (Indexed (normaliseType ty,x,fI)))) - expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do syn <- Mon hdlSyn case syn of @@ -1678,9 +1667,6 @@ expr_ _ (DataCon (CustomSP _ dataRepr size args) (DC (_,i)) es) = expr_ _ (DataCon ty@(Product _ labels tys) _ es) = tupled $ zipWithM (\i e' -> tyName ty <> selectProductField labels tys i <+> rarrow <+> expr_ False e') [0..] es -expr_ p (DataCon ty@(Clock _ _ Gated) x es) = do - expr_ p (DataCon (normaliseType ty) x es) - expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Signed.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx @@ -1999,11 +1985,9 @@ punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon m Doc punctuate' s d = vcat (punctuate s d) <> s encodingNote :: HWType -> VHDLM Doc -encodingNote (Clock _ _ Gated) = "-- gated clock" <> line -encodingNote (Clock _ _ Source) = "-- clock" <> line -encodingNote (Reset _ _ Asynchronous) = "-- asynchronous reset: active high" <> line -encodingNote (Reset _ _ Synchronous) = "-- synchronous reset: active high" <> line -encodingNote _ = emptyDoc +encodingNote (Clock _) = "-- clock" <> line +encodingNote (Reset _ ) = "-- reset" <> line +encodingNote _ = emptyDoc tupledSemi :: Applicative f => f [Doc] -> f Doc tupledSemi = align . encloseSep (flatAlt (lparen <+> emptyDoc) lparen) diff --git a/clash-lib/src/Clash/Backend/Verilog.hs b/clash-lib/src/Clash/Backend/Verilog.hs index 907fd95d91..6fc28c293a 100644 --- a/clash-lib/src/Clash/Backend/Verilog.hs +++ b/clash-lib/src/Clash/Backend/Verilog.hs @@ -68,7 +68,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 (..), ResetKind (..)) import Clash.Util (SrcSpan, noSrcSpan, curLoc, traceIf, (<:>),on,first) @@ -343,7 +342,6 @@ verilogType' isDecl t = in case t of -- special case: Bit, Bool, clocks and resets - Clock _ _ Gated -> verilogType' isDecl (gatedClockType t) Clock {} -> emptyDoc Reset {} -> emptyDoc Bit -> emptyDoc @@ -353,12 +351,6 @@ verilogType' isDecl t = ty | (prefix, sz) <- getVerilogTy ty -> prefix <> renderVerilogTySize (sz-1) -gatedClockType :: HWType -> HWType -gatedClockType (Clock _ _ Gated) = - Product "GatedClock" (Just ["clk", "enable"]) [Bit,Bool] -gatedClockType ty = ty -{-# INLINE gatedClockType #-} - sigDecl :: VerilogM Doc -> HWType -> VerilogM Doc sigDecl d t = verilogType t <+> d @@ -574,15 +566,6 @@ modifier offset (Indexed (ty@(Product _ _ argTys),_,fI)) = Just (start+offset,en start = typeSize ty - 1 - otherSz end = start - argSize + 1 -modifier offset (Indexed (ty@(Clock _ _ Gated),_,fI)) = Just (start+offset,end+offset, argTy) - where - argTys = [Bit, Bool] - argTy = argTys !! fI - argSize = typeSize argTy - otherSz = otherSize argTys (fI - 1) - start = typeSize ty - 1 - otherSz - end = start - argSize + 1 - modifier offset (Indexed (ty@(Vector _ argTy),1,0)) = Just (start+offset,end+offset, argTy) where argSize = typeSize argTy @@ -771,8 +754,6 @@ expr_ _ (DataCon (CustomSP name' dataRepr size args) (DC (_,constrNr)) es) = expr_ _ (DataCon (Product {}) _ es) = listBraces (mapM (expr_ False) es) -expr_ _ (DataCon (Clock _ _ Gated) _ es) = listBraces (mapM (expr_ False) es) - expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Signed.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx @@ -935,8 +916,6 @@ punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon m Doc punctuate' s d = vcat (punctuate s d) <> s encodingNote :: Applicative m => HWType -> m Doc -encodingNote (Clock _ _ Gated) = string " // gated clock" -encodingNote (Clock _ _ Source) = string " // clock" -encodingNote (Reset _ _ Asynchronous) = string " // asynchronous reset: active high" -encodingNote (Reset _ _ Synchronous) = string " // synchronous reset: active high" -encodingNote _ = emptyDoc +encodingNote (Clock _) = string " // clock" +encodingNote (Reset _) = string " // reset" +encodingNote _ = emptyDoc diff --git a/clash-lib/src/Clash/Netlist.hs b/clash-lib/src/Clash/Netlist.hs index 22fc9c7e64..2e66eb5909 100644 --- a/clash-lib/src/Clash/Netlist.hs +++ b/clash-lib/src/Clash/Netlist.hs @@ -794,4 +794,17 @@ mkDcApplication dstHType bndr dc args = do -> pure (head argExprs) | dcNm == "GHC.Natural.NatJ#" -> pure (head argExprs) - _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) +-- KnownDomain {} -> +-- return (Identifier "__KNOWNDOMAIN__" Nothing) +-- pure $ +-- error $ $(curLoc) ++ "mkDcApplication undefined for KnownDomain. " +-- ++ "Did a blackbox definition try to render it? " +-- ++ "Context: \n\n" +-- ++ "dstHType: " ++ show dstHType ++ "\n\n" +-- ++ "dc: " ++ show dc ++ "\n\n" +-- ++ "args: " ++ show args ++ "\n\n" +-- ++ "argHWTys: " ++ show argHWTys ++ "\n\n" +-- ++ "Callstack: " +-- ++ prettyCallStack callStack + _ -> + error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) diff --git a/clash-lib/src/Clash/Netlist/BlackBox.hs b/clash-lib/src/Clash/Netlist/BlackBox.hs index 1565d06bc4..d543d8e6d2 100644 --- a/clash-lib/src/Clash/Netlist/BlackBox.hs +++ b/clash-lib/src/Clash/Netlist/BlackBox.hs @@ -98,12 +98,14 @@ warn opts msg = do -- | Generate the context for a BlackBox instantiation. mkBlackBoxContext - :: Id + :: TextS.Text + -- ^ Blackbox function name + -> Id -- ^ Identifier binding the primitive/blackbox application -> [Term] -- ^ Arguments of the primitive/blackbox application -> NetlistMonad (BlackBoxContext,[Declaration]) -mkBlackBoxContext resId args = do +mkBlackBoxContext bbName resId args = do -- Make context inputs tcm <- Lens.use tcCache let resNm = nameOcc (varName resId) @@ -117,7 +119,7 @@ mkBlackBoxContext resId args = do lvl <- Lens.use curBBlvl (nm,_) <- Lens.use curCompNm - return ( Context (res,resTy) imps funs [] lvl nm + return ( Context bbName (res,resTy) imps funs [] lvl nm , concat impDecls ++ concat funDecls ) where @@ -309,7 +311,7 @@ mkPrimitive bbEParen bbEasD dst nm args ty = resM <- resBndr True wr' dst case resM of Just (dst',dstNm,dstDecl) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst' (lefts args) (templ,templDecl) <- prepareBlackBox pNm tempD bbCtx let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) (includes p) templ bbCtx @@ -323,7 +325,7 @@ mkPrimitive bbEParen bbEasD dst nm args ty = resM <- resBndr True Wire dst case resM of Just (dst',dstNm,dstDecl) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst' (lefts args) (bbTempl,templDecl) <- prepareBlackBox pNm tempE bbCtx let tmpAssgn = Assignment dstNm (BlackBoxE pNm (libraries p) (imports p) @@ -335,7 +337,7 @@ mkPrimitive bbEParen bbEasD dst nm args ty = resM <- resBndr False Wire dst case resM of Just (dst',_,_) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst' (lefts args) (bbTempl,templDecl0) <- prepareBlackBox pNm tempE bbCtx let templDecl1 = case nm of "Clash.Sized.Internal.BitVector.fromInteger#" @@ -394,7 +396,7 @@ mkPrimitive bbEParen bbEasD dst nm args ty = | otherwise -> return (BlackBoxE "" [] [] [] (BBTemplate [Text $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]]) - emptyBBContext False,[]) + (emptyBBContext pNm) False,[]) resBndr :: Bool @@ -443,7 +445,7 @@ mkFunInput resId e = do -- TODO: Rewrite this function to use blackbox functions. Right now it -- TODO: generates strings that are later parsed/interpreted again. Silly! let (appE,args) = collectArgs e - (bbCtx,dcls) <- mkBlackBoxContext resId (lefts args) + (bbCtx,dcls) <- mkBlackBoxContext "__INTERNAL__" resId (lefts args) templ <- case appE of Prim nm _ -> do bb <- extractPrimWarnOrFail nm diff --git a/clash-lib/src/Clash/Netlist/BlackBox/Parser.hs b/clash-lib/src/Clash/Netlist/BlackBox/Parser.hs index 2c72d2f992..d64b2025be 100644 --- a/clash-lib/src/Clash/Netlist/BlackBox/Parser.hs +++ b/clash-lib/src/Clash/Netlist/BlackBox/Parser.hs @@ -105,8 +105,8 @@ pTagE = Result True <$ string "~ERESULT" <|> Sel <$> (string "~SEL" *> brackets' pTagE) <*> brackets' natural' <|> IsLit <$> (string "~ISLIT" *> brackets' natural') <|> IsVar <$> (string "~ISVAR" *> brackets' natural') - <|> IsGated <$> (string "~ISGATED" *> brackets' natural') - <|> IsSync <$> (string "~ISSYNC" *> brackets' natural') + <|> IsActiveHigh <$> (string "~ISACTIVEHIGH" *> brackets' natural') + <|> IsEnabled <$> (string "~ISENABLED" *> brackets' natural') <|> StrCmp <$> (string "~STRCMP" *> brackets' pSigD) <*> brackets' natural' <|> OutputWireReg <$> (string "~OUTPUTWIREREG" *> brackets' natural') <|> GenSym <$> (string "~GENSYM" *> brackets' pSigD) <*> brackets' natural' @@ -116,6 +116,13 @@ pTagE = Result True <$ string "~ERESULT" <|> And <$> (string "~AND" *> brackets' (commaSep pTagE)) <|> Vars <$> (string "~VARS" *> brackets' natural') + -- Domain attributes: + <|> Tag <$> (string "~TAG" *> brackets' natural') + <|> Period <$> (string "~PERIOD" *> brackets' natural') + <|> IsRisingEdge <$> (string "~ISRISINGEDGE" *> brackets' natural') + <|> IsSync <$> (string "~ISSYNC" *> brackets' natural') + <|> IsInitDefined <$> (string "~ISINITDEFINED" *> brackets' natural') + natural' :: TokenParsing m => m Int natural' = fmap fromInteger natural diff --git a/clash-lib/src/Clash/Netlist/BlackBox/Types.hs b/clash-lib/src/Clash/Netlist/BlackBox/Types.hs index 505c7eba59..bca89eaadf 100644 --- a/clash-lib/src/Clash/Netlist/BlackBox/Types.hs +++ b/clash-lib/src/Clash/Netlist/BlackBox/Types.hs @@ -71,6 +71,7 @@ type BlackBoxFunction -> NetlistMonad (Either String (BlackBoxMeta, BlackBox)) -- | A BlackBox Template is a List of Elements +-- TODO: Add name of function for better error messages type BlackBoxTemplate = [Element] -- | Elements of a blackbox context. If you extend this list, make sure to @@ -148,8 +149,20 @@ data Element -- ^ Record selector of a type | IsLit !Int | IsVar !Int - | IsGated !Int + | IsActiveHigh !Int + -- ^ Whether a domain's reset lines are synchronous. + | Tag !Int + -- ^ Tag of a domain. + | Period !Int + -- ^ Period of a domain. + | IsRisingEdge !Int + -- ^ Which clock edge memory elements are sensitive to. | IsSync !Int + -- ^ Whether a domain's reset lines are synchronous. Errors if not applied to + -- a KnownDomain. + | IsInitDefined !Int + | IsEnabled !Int + -- ^ Whether reset line is constantly enabled | StrCmp [Element] !Int | OutputWireReg !Int | Vars !Int diff --git a/clash-lib/src/Clash/Netlist/BlackBox/Util.hs b/clash-lib/src/Clash/Netlist/BlackBox/Util.hs index 51f00480c5..1207fbb644 100644 --- a/clash-lib/src/Clash/Netlist/BlackBox/Util.hs +++ b/clash-lib/src/Clash/Netlist/BlackBox/Util.hs @@ -57,10 +57,16 @@ import Clash.Netlist.Types (BlackBoxContext (..), Declaration(BlackBoxD)) import qualified Clash.Netlist.Types as N import Clash.Netlist.Util (typeSize) -import Clash.Signal.Internal (ClockKind (Gated), - ResetKind (Synchronous)) +import Clash.Signal.Internal + (ResetKind(..), ResetPolarity(..), ActiveEdge(..), InitBehavior(..)) import Clash.Util +-- | Strip as many "Void" layers as possible. Might still return a Void if the +-- void doesn't contain a hwtype. +stripVoid :: HWType -> HWType +stripVoid (Void (Just e)) = stripVoid e +stripVoid e = e + inputHole :: Element -> Maybe Int inputHole = \case Arg _ n -> pure n @@ -330,6 +336,23 @@ renderElem b (SigD e m) = do t <- getMon (hdlSig e' ty) return (const (renderOneLine t)) +renderElem b (Period n) = do + let (_, ty, _) = bbInputs b !! n + case stripVoid ty of + KnownDomain _ period _ _ _ _ -> + return $ const $ Text.pack $ show period + _ -> + error $ $(curLoc) ++ "Period: Expected KnownDomain, not: " ++ show ty + +renderElem b (Tag n) = do + let (_, ty, _) = bbInputs b !! n + case stripVoid ty of + KnownDomain dom _ _ _ _ _ -> + return (const (Text.pack (Data.Text.unpack dom))) + _ -> + error $ $(curLoc) ++ "Tag: Expected KnownDomain, not: " ++ show ty + + renderElem b (IF c t f) = do iw <- iwWidth syn <- hdlSyn @@ -374,14 +397,49 @@ renderElem b (IF c t f) = do Literal {} -> 1 BlackBoxE {} -> 1 _ -> 0 - (IsGated n) -> let (_,ty,_) = bbInputs b !! n - in case ty of - Clock _ _ Gated -> 1 - _ -> 0 - (IsSync n) -> let (_,ty,_) = bbInputs b !! n - in case ty of - Reset _ _ Synchronous -> 1 - _ -> 0 + + (IsEnabled n) -> + let (e, ty, _) = bbInputs b !! n in + case (e, ty) of + (Literal Nothing (BoolLit True), Bool) -> 0 + -- TODO: Emit warning? If enable signal is inferred as always False, + -- TODO: the component will never be enabled. This is probably not the + -- TODO: user's intention. + (Literal Nothing (BoolLit False), Bool) -> 1 + (_, Bool) -> 1 + _ -> + error $ $(curLoc) ++ "IsEnabled: Expected Bool, not: " ++ show ty + +-- error $ show (e, ty, isLit, bbName b) + + (IsRisingEdge n) -> + let (_, ty, _) = bbInputs b !! n in + case stripVoid ty of + KnownDomain _ _ Rising _ _ _ -> 1 + KnownDomain _ _ Falling _ _ _ -> 0 + _ -> error $ $(curLoc) ++ "IsRisingEdge: Expected KnownDomain, not: " ++ show ty + + (IsSync n) -> + let (_, ty, _) = bbInputs b !! n in + case stripVoid ty of + KnownDomain _ _ _ Synchronous _ _ -> 1 + KnownDomain _ _ _ Asynchronous _ _ -> 0 + _ -> error $ $(curLoc) ++ "IsSync: Expected KnownDomain, not: " ++ show ty + + (IsInitDefined n) -> + let (_, ty, _) = bbInputs b !! n in + case stripVoid ty of + KnownDomain _ _ _ _ Defined _ -> 1 + KnownDomain _ _ _ _ Undefined _ -> 0 + _ -> error $ $(curLoc) ++ "IsInitDefined: Expected KnownDomain, not: " ++ show ty + + (IsActiveHigh n) -> + let (_, ty, _) = bbInputs b !! n in + case stripVoid ty of + KnownDomain _ _ _ _ _ ActiveHigh -> 1 + KnownDomain _ _ _ _ _ ActiveLow -> 0 + _ -> error $ $(curLoc) ++ "IsActiveHigh: Expected KnownDomain, not: " ++ show ty + (StrCmp [Text t1] n) -> let (e,_,_) = bbInputs b !! n in case exprToString e of @@ -746,8 +804,16 @@ prettyElem (Sel e i) = do renderOneLine <$> (string "~SEL" <> brackets (string e') <> brackets (int i)) prettyElem (IsLit i) = renderOneLine <$> (string "~ISLIT" <> brackets (int i)) prettyElem (IsVar i) = renderOneLine <$> (string "~ISVAR" <> brackets (int i)) -prettyElem (IsGated i) = renderOneLine <$> (string "~ISGATED" <> brackets (int i)) +prettyElem (IsActiveHigh i) = renderOneLine <$> (string "~ISACTIVEHIGH" <> brackets (int i)) +prettyElem (IsEnabled i) = renderOneLine <$> (string "~ISENABLED" <> brackets (int i)) + +-- Domain attributes: +prettyElem (Tag i) = renderOneLine <$> (string "~TAG" <> brackets (int i)) +prettyElem (Period i) = renderOneLine <$> (string "~PERIOD" <> brackets (int i)) +prettyElem (IsRisingEdge i) = renderOneLine <$> (string "~ISRISINGEDGE" <> brackets (int i)) prettyElem (IsSync i) = renderOneLine <$> (string "~ISSYNC" <> brackets (int i)) +prettyElem (IsInitDefined i) = renderOneLine <$> (string "~ISINITDEFINED" <> brackets (int i)) + prettyElem (StrCmp es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~STRCMP" <> brackets (string es') <> brackets (int i)) @@ -841,8 +907,13 @@ walkElement f el = maybeToList (f el) ++ walked Sel e _ -> go e IsLit _ -> [] IsVar _ -> [] - IsGated _ -> [] + Tag _ -> [] + Period _ -> [] + IsRisingEdge _ -> [] IsSync _ -> [] + IsInitDefined _ -> [] + IsActiveHigh _ -> [] + IsEnabled _ -> [] StrCmp es _ -> concatMap go es OutputWireReg _ -> [] Vars _ -> [] @@ -876,13 +947,60 @@ usedArguments :: N.BlackBox -> [Int] usedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k usedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t) where - matchArg (Component (Decl i _)) = Just i - matchArg (Arg _ i) = Just i - matchArg (Lit i) = Just i - matchArg (Name i) = Just i - matchArg (Var _ i) = Just i - matchArg (Const i) = Just i - matchArg _ = Nothing + matchArg = + \case + Arg _ i -> Just i + Component (Decl i _) -> Just i + Const i -> Just i + IsLit i -> Just i + IsEnabled i -> Just i + Lit i -> Just i + Name i -> Just i + Var _ i -> Just i + + -- Domain properties (only need type): + IsInitDefined _ -> Nothing + IsRisingEdge _ -> Nothing + IsSync _ -> Nothing + Period _ -> Nothing + Tag _ -> Nothing + + -- Others. Template tags only using types of arguments can be considered + -- "not used". + And _ -> Nothing + ArgGen _ _ -> Nothing + BV _ _ _ -> Nothing + CmpLE _ _ -> Nothing + CompName -> Nothing + Depth _ -> Nothing + DevNull _ -> Nothing + Err _ -> Nothing + FilePath _ -> Nothing + Gen _ -> Nothing + GenSym _ _ -> Nothing + HdlSyn _ -> Nothing + IF _ _ _ -> Nothing + IncludeName _ -> Nothing + IndexType _ -> Nothing + IsActiveHigh _ -> Nothing + IsVar _ -> Nothing + IW64 -> Nothing + Length _ -> Nothing + MaxIndex _ -> Nothing + OutputWireReg _ -> Nothing + Repeat _ _ -> Nothing + Result _ -> Nothing + Sel _ _ -> Nothing + SigD _ _ -> Nothing + Size _ -> Nothing + StrCmp _ _ -> Nothing + Sym _ _ -> Nothing + Template _ _ -> Nothing + Text _ -> Nothing + Typ _ -> Nothing + TypElem _ -> Nothing + TypM _ -> Nothing + Vars _ -> Nothing onBlackBox :: (BlackBoxTemplate -> r) diff --git a/clash-lib/src/Clash/Netlist/Types.hs b/clash-lib/src/Clash/Netlist/Types.hs index ccf3e60938..ecdc4747fa 100644 --- a/clash-lib/src/Clash/Netlist/Types.hs +++ b/clash-lib/src/Clash/Netlist/Types.hs @@ -19,7 +19,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Clash.Netlist.Types ( Declaration (..,NetDecl) @@ -33,7 +32,7 @@ import Control.Monad.State (State) import Control.Monad.State.Strict (MonadIO, MonadState, StateT) import Data.Bits (testBit) import Data.Binary (Binary(..)) -import Data.Hashable +import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.IntMap (IntMap, empty) import qualified Data.Set as Set @@ -55,7 +54,8 @@ import Clash.Driver.Types (BindingMap, ClashOpts) import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) import Clash.Netlist.Id (IdType) import Clash.Primitives.Types (CompiledPrimMap) -import Clash.Signal.Internal (ClockKind, ResetKind) +import Clash.Signal.Internal + (ResetPolarity, ActiveEdge, ResetKind, InitBehavior) import Clash.Util (makeLenses) import Clash.Annotations.BitRepresentation.Internal @@ -152,29 +152,29 @@ data HWType -- ^ Boolean type | Bit -- ^ Bit type - | BitVector !Size + | BitVector !Size -- ^ BitVector of a specified size - | Index !Integer + | Index !Integer -- ^ Unsigned integer with specified (exclusive) upper bounder - | Signed !Size + | Signed !Size -- ^ Signed integer of a specified size - | Unsigned !Size + | Unsigned !Size -- ^ Unsigned integer of a specified size - | Vector !Size !HWType + | Vector !Size !HWType -- ^ Vector type - | RTree !Size !HWType + | RTree !Size !HWType -- ^ RTree type - | Sum !Identifier [Identifier] + | Sum !Identifier [Identifier] -- ^ Sum type: Name and Constructor names - | Product !Identifier (Maybe [Text]) [HWType] + | Product !Identifier (Maybe [Text]) [HWType] -- ^ Product type: Name, field names, and field types. Field names will be -- populated when using records. - | SP !Identifier [(Identifier,[HWType])] + | SP !Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types - | Clock !Identifier !Integer !ClockKind - -- ^ Clock type with specified name and period - | Reset !Identifier !Integer !ResetKind - -- ^ Reset type corresponding to clock with a specified name and period + | Clock !Identifier + -- ^ Clock type corresponding to domain /Identifier/ + | Reset !Identifier + -- ^ Reset type corresponding to domain /Identifier/ | BiDirectional !PortDirection !HWType -- ^ Tagging type indicating a bidirectional (inout) port | CustomSP !Identifier !DataRepr' !Size [(ConstrRepr', Identifier, [HWType])] @@ -184,14 +184,10 @@ data HWType -- ^ Same as Sum, but with a user specified bit representation. For more info, -- see: Clash.Annotations.BitRepresentations. | Annotated [Attr'] !HWType - -- ^ Annotated - deriving (Eq,Ord,Show,Generic) - -instance Hashable ClockKind -instance Hashable ResetKind - -instance Hashable HWType -instance NFData HWType + -- ^ Annotated with HDL attributes + | KnownDomain !Identifier !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity + -- ^ Domain name, period, active edge, reset kind, initial value behavior + deriving (Eq, Ord, Show, Generic, NFData, Hashable) -- | Extract hardware attributes from Annotated. Returns an empty list if -- non-Annotated given or if Annotated has an empty list of attributes. @@ -347,7 +343,8 @@ toBit m i = if testBit m 0 -- | Context used to fill in the holes of a BlackBox template data BlackBoxContext = Context - { bbResult :: (Expr,HWType) -- ^ Result name and type + { bbName :: Text -- ^ Blackbox function name (for error reporting) + , bbResult :: (Expr,HWType) -- ^ Result name and type , bbInputs :: [(Expr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal , bbFunctions :: IntMap (Either BlackBox (Identifier,[Declaration]) ,WireOrReg @@ -400,10 +397,11 @@ instance Binary TemplateFunction where get = (\is -> TemplateFunction is err err) <$> get where err = const $ error "TemplateFunction functions can't be preserved by serialisation" -emptyBBContext :: BlackBoxContext -emptyBBContext +emptyBBContext :: Text -> BlackBoxContext +emptyBBContext n = Context - { bbResult = (Identifier (pack "__EMPTY__") Nothing, Void Nothing) + { bbName = n + , bbResult = (Identifier (pack "__EMPTY__") Nothing, Void Nothing) , bbInputs = [] , bbFunctions = empty , bbQsysIncName = [] diff --git a/clash-lib/src/Clash/Netlist/Util.hs b/clash-lib/src/Clash/Netlist/Util.hs index aaec7c5008..8d52b3a00a 100644 --- a/clash-lib/src/Clash/Netlist/Util.hs +++ b/clash-lib/src/Clash/Netlist/Util.hs @@ -24,7 +24,6 @@ import Control.Exception (throw) import Control.Lens ((.=),(%=)) import qualified Control.Lens as Lens import Control.Monad (unless, when, zipWithM, join) -import Control.Monad.Trans.Except (runExcept) import Data.Either (partitionEithers) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -55,13 +54,13 @@ import Clash.Core.Name import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (Subst (..), extendIdSubst, extendIdSubstList, extendInScopeId, - extendInScopeIdList, extendTvSubstList, mkSubst, substTm, substTy, substTyWith) + extendInScopeIdList, extendTvSubstList, mkSubst, substTm, substTy) import Clash.Core.Term (Alt, LetBinding, Pat (..), Term (..)) import Clash.Core.TyCon (TyConName, TyConMap, tyConDataCons) -import Clash.Core.Type (Type (..), TypeView (..), LitTy (..), +import Clash.Core.Type (Type (..), TypeView (..), coreView1, splitTyConAppM, tyView, TyVar) -import Clash.Core.Util (collectBndrs, termType, tyNatSize) +import Clash.Core.Util (collectBndrs, termType) import Clash.Core.Var (Id, Var (..), mkLocalId, modifyVarName, Attr') import Clash.Core.VarEnv @@ -69,7 +68,6 @@ import Clash.Core.VarEnv unionVarSet, uniqAway, unitVarSet) import Clash.Netlist.Id (IdType (..), stripDollarPrefixes) import Clash.Netlist.Types as HW -import Clash.Signal.Internal (ClockKind (..)) import Clash.Unique import Clash.Util @@ -196,37 +194,6 @@ coreTypeToHWTypeM ty = <*> Lens.use tcCache <*> pure ty) --- | Returns the name and period of the clock corresponding to a type -synchronizedClk - :: TyConMap - -- ^ TyCon cache - -> Type - -> Maybe (Identifier,Integer) -synchronizedClk tcm ty - | not . null . Lens.toListOf typeFreeVars $ ty = Nothing - | Just (tcNm,args) <- splitTyConAppM ty - = case nameOcc tcNm of - "Clash.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) - "Clash.Signal.Internal.SClock" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),litTy]) - | Right i <- runExcept (tyNatSize tcm litTy) -> Just (Text.pack s,i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showPpr ty - "Clash.Signal.Internal.Signal" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),litTy]) - | Right i <- runExcept (tyNatSize tcm litTy) -> Just (Text.pack s,i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showPpr ty - _ -> case tyConDataCons (tcm `lookupUniqMap'` tcNm) of - [dc] -> let argTys = dcArgTys dc - argTVs = dcUnivTyVars dc - -- argSubts = zip argTVs args - args' = map (substTyWith argTVs args) argTys - in case args' of - (arg:_) -> synchronizedClk tcm arg - _ -> Nothing - _ -> Nothing - | otherwise - = Nothing - packSP :: CustomReprs -> (Text, c) @@ -501,10 +468,10 @@ typeSize :: HWType typeSize (Void {}) = 0 typeSize String = 0 typeSize Integer = 0 +typeSize (KnownDomain {}) = 0 typeSize Bool = 1 typeSize Bit = 1 -typeSize (Clock _ _ Source) = 1 -typeSize (Clock _ _ Gated) = 2 +typeSize (Clock _) = 1 typeSize (Reset {}) = 1 typeSize (BitVector i) = i typeSize (Index 0) = 0 @@ -990,14 +957,6 @@ mkInput pM = case pM of else throwAnnotatedSplitError $(curLoc) "Product" - Clock _ _ Gated -> do - arguments <- splitGatedClock i' hwty - (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments - let netdecl = NetDecl Nothing i' hwty - dcExpr = DataCon hwty (DC (hwty,0)) exprs - netassgn = Assignment i' dcExpr - return (concat ports,[netdecl,netassgn],dcExpr,i') - _ -> return ([(i',hwty)],[],Identifier i' Nothing,i') @@ -1064,14 +1023,6 @@ mkInput pM = case pM of return (concat ports,[netdecl,netassgn],dcExpr,pN) _ -> error "Unexpected error for PortProduct" - Clock _ _ Gated -> do - arguments <- splitGatedClock pN hwty - (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts $ map (prefixParent p) ps) arguments - let netdecl = NetDecl Nothing pN hwty - dcExpr = DataCon hwty (DC (hwty,0)) exprs - netassgn = Assignment pN dcExpr - return (concat ports,[netdecl,netassgn],dcExpr,pN) - _ -> return ([(pN,hwty)],[],Identifier pN Nothing,pN) -- | Create a Vector chain for a list of 'Identifier's @@ -1208,13 +1159,6 @@ mkOutput' pM = case pM of else throwAnnotatedSplitError $(curLoc) "Product" - Clock _ _ Gated -> do - results <- splitGatedClock o' hwty - (ports,decls,ids) <- unzip3 <$> mapM (mkOutput' Nothing) results - let netdecl = NetDecl Nothing o' hwty - assigns = zipWith (assignId o' hwty 0) ids [0..] - return (concat ports,netdecl:assigns ++ concat decls,o') - _ -> return ([(o',hwty)],[],o') go' (PortName p) (o,hwty) = do @@ -1281,14 +1225,6 @@ mkOutput' pM = case pM of in return (concat ports,netdecl:assigns ++ concat decls,pN) _ -> error "Unexpected error for PortProduct" - Clock _ _ Gated -> do - results <- splitGatedClock pN hwty - let resultsBundled = (extendPorts $ map (prefixParent p) ps, results) - (ports,decls,ids) <- unzip3 <$> uncurry (zipWithM mkOutput') resultsBundled - let netdecl = NetDecl Nothing pN hwty - assigns = zipWith (assignId pN hwty 0) ids [0..] - return (concat ports,netdecl:assigns ++ concat decls,pN) - _ -> return ([(pN,hwty)],[],pN) assignId p hwty con i n = @@ -1416,7 +1352,6 @@ doConv hwty (Just topM) b e = case hwty of Vector {} -> ConvBV topM hwty b e RTree {} -> ConvBV topM hwty b e Product {} -> ConvBV topM hwty b e - Clock _ _ Gated -> ConvBV topM hwty b e _ -> e -- | Generate input port mappings for the TopEntity @@ -1478,15 +1413,6 @@ mkTopInput topM inps pM = case pM of else throwAnnotatedSplitError $(curLoc) "Product" - Clock _ _ Gated -> do - arguments <- splitGatedClock i' hwty - (inps'',arguments1) <- mapAccumLM go inps' arguments - let (ports,decls,ids) = unzip3 arguments1 - assigns = zipWith (argBV topM) ids - [ Identifier i' (Just (Indexed (hwty,0,n))) - | n <- [0..]] - return (inps'',(concat ports,iDecl:assigns++concat decls,Left i')) - _ -> return (rest,([(iN,i',hwty)],[iDecl],Left i')) go [] _ = error "This shouldn't happen" @@ -1572,17 +1498,6 @@ mkTopInput topM inps pM = case pM of return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN')) _ -> error "Unexpected error for PortProduct" - Clock _ _ Gated -> do - arguments <- splitGatedClock pN' hwty - (inps'',arguments1) <- - mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps' - (zip (extendPorts ps) arguments) - let (ports,decls,ids) = unzip3 arguments1 - assigns = zipWith (argBV topM) ids - [ Identifier pN' (Just (Indexed (hwty,0,n))) - | n <- [0..]] - return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN')) - _ -> return (tail inps',([(pN,pN',hwty)],[pDecl],Left pN')) @@ -1689,17 +1604,6 @@ mkTopOutput' topM outps pM = case pM of else throwAnnotatedSplitError $(curLoc) "Product" - Clock _ _ Gated -> do - results <- splitGatedClock o' hwty - (outps'',results1) <- mapAccumLM go outps' results - let (ports,decls,ids) = unzip3 results1 - ids' = map (resBV topM) ids - netassgn = Assignment o' (DataCon hwty (DC (hwty,0)) ids') - if null attrs then - return (outps'', (concat ports,oDecl:netassgn:concat decls,Left o')) - else - throwAnnotatedSplitError $(curLoc) $ show hwty - _ -> return (rest,([(oN,o',hwty)],[oDecl],Left o')) go [] _ = error "This shouldn't happen" @@ -1773,17 +1677,6 @@ mkTopOutput' topM outps pM = case pM of netassgn = Assignment pN' (DataCon hwty (DC (BitVector (typeSize hwty),0)) ids2) return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN')) - Clock _ _ Gated -> do - results <- splitGatedClock pN hwty - (outps'',results1) <- mapAccumLM go outps' results - let (ports,decls,ids) = unzip3 results1 - ids' = map (resBV topM) ids - netassgn = Assignment pN' (DataCon hwty (DC (hwty,0)) ids') - if null attrs then - return (outps'', (concat ports,pDecl:netassgn:concat decls,Left pN')) - else - throwAnnotatedSplitError $(curLoc) $ show hwty - _ -> return (tail outps',([(pN,pN',hwty)],[pDecl],Left pN')) concatPortDecls3 @@ -1842,15 +1735,6 @@ nestM (Indexed (RTree (-1) t1,l,_)) (Indexed (RTree d t2,10,k)) nestM _ _ = Nothing -splitGatedClock :: Identifier -> HWType -> NetlistMonad [(Identifier,HWType)] -splitGatedClock baseNm (Clock nm rt Gated) = do - hwnms <- mapM (extendIdentifier Basic baseNm) partNms - return $ zip hwnms hwtys - where - hwtys = [Clock nm rt Source,Bool] - partNms = ["_clk","_clken"] -splitGatedClock _ ty = error $ $(curLoc) ++ "splitGatedClock can't split: " ++ show ty - -- | Determines if any type variables (exts) are bound in any of the given -- type or term variables (tms). It's currently only used to detect bound -- existentials, hence the name.