Merge pull request #2590 from clash-lang/remove-KnownDomain-preparation

leonschoorl · web-flow · commit d43460b28e05 · 2023-11-02T17:27:36.000+01:00
Remove KnownDomain preparation
diff --git a/changelog/2023-10-02T15_07_39+02_00_remove_KnownDomain-preparation b/changelog/2023-10-02T15_07_39+02_00_remove_KnownDomain-preparation
@@ -0,0 +1,5 @@
+ADDED: You can now use ~PERIOD, ~ISSYNC, ~ISINITDEFINED and ~ACTIVEEDGE
+on arguments of type Clock,Reset,Enable,ClockN and DiffClock.
+
+CHANGED: unsafeToReset and invertReset now have a KnownDomain constraint
+This was done in preparation for [Remove KnownDomain #2589](https://github.com/clash-lang/clash-compiler/pull/2589)
diff --git a/clash-cores/src/Clash/Cores/Xilinx/DcFifo/Internal/BlackBoxes.hs b/clash-cores/src/Clash/Cores/Xilinx/DcFifo/Internal/BlackBoxes.hs
@@ -178,7 +178,7 @@ dcFifoBBTF DcConfig{..} bbCtx
       let domty = DSL.ety knownDomainWrite
       in case stripVoid domty of
            N.KnownDomain _ _ _ Synchronous _ _ ->
-             DSL.unsafeToActiveHigh "wr_rst_high" domty wRst
+             DSL.unsafeToActiveHigh "wr_rst_high" wRst
            N.KnownDomain _ _ _ Asynchronous _ _ ->
              error $
                show 'dcFifoTF <> ": dcFifo only supports synchronous resets"
@@ -190,7 +190,7 @@ dcFifoBBTF DcConfig{..} bbCtx
       let domty = DSL.ety knownDomainRead
       in case stripVoid domty of
            N.KnownDomain _ _ _ Synchronous _ _ ->
-             DSL.unsafeToActiveHigh "rd_rst_high" domty rRst
+             DSL.unsafeToActiveHigh "rd_rst_high" rRst
            N.KnownDomain _ _ _ Asynchronous _ _ ->
              error $
                show 'dcFifoTF <> ": dcFifo only supports synchronous resets"
diff --git a/clash-lib/clash-lib.cabal b/clash-lib/clash-lib.cabal
@@ -359,7 +359,6 @@ executable static-files
     docopt                  ^>= 0.7,
     extra,
     filepath
-  Other-Modules:      Paths_clash_lib
   GHC-Options:        -Wall -Wcompat
   default-language:   Haskell2010
   if impl(ghc >= 9.2.0)
diff --git a/clash-lib/prims/commonverilog/Clash_Signal_Internal.primitives.yaml b/clash-lib/prims/commonverilog/Clash_Signal_Internal.primitives.yaml
@@ -9,6 +9,6 @@
     name: Clash.Signal.Internal.unsafeToReset
     kind: Expression
     type: 'unsafeToReset ::
-      Signal dom Bool -> Reset dom'
-    template: ~ARG[0]
+      KnownDomain dom => Signal dom Bool -> Reset dom'
+    template: ~ARG[1]
     workInfo: Never
diff --git a/clash-lib/prims/vhdl/Clash_Signal_Internal.primitives.yaml b/clash-lib/prims/vhdl/Clash_Signal_Internal.primitives.yaml
@@ -230,6 +230,6 @@
     name: Clash.Signal.Internal.unsafeToReset
     kind: Declaration
     type: 'unsafeToReset ::
-      Signal dom Bool -> Reset dom'
-    template: ~RESULT <= '1' when ~ARG[0] = true else '0';
+      KnownDomain dom => Signal dom Bool -> Reset dom'
+    template: ~RESULT <= '1' when ~ARG[1] = true else '0';
     workInfo: Never
diff --git a/clash-lib/src/Clash/Netlist/BlackBox/Util.hs b/clash-lib/src/Clash/Netlist/BlackBox/Util.hs
@@ -57,15 +57,15 @@ import           Text.Read                       (readEither)
 import           Text.Trifecta.Result            hiding (Err)
 
 import           Clash.Backend
-  (Backend (..), Usage (..), AggressiveXOptBB(..), RenderEnums(..))
+  (Backend (..), DomainMap, Usage (..), AggressiveXOptBB(..), RenderEnums(..))
 import           Clash.Netlist.BlackBox.Parser
 import           Clash.Netlist.BlackBox.Types
 import           Clash.Netlist.Types
   (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),
    Declaration(BlackBoxD))
 import qualified Clash.Netlist.Id                as Id
 import qualified Clash.Netlist.Types             as N
-import           Clash.Netlist.Util              (typeSize, isVoid, stripVoid)
+import           Clash.Netlist.Util              (typeSize, isVoid, stripAttributes, stripVoid)
 import           Clash.Signal.Internal
   (ResetKind(..), ResetPolarity(..), InitBehavior(..), VDomainConfiguration (..))
 import           Clash.Util
@@ -185,10 +185,11 @@ verifyBlackBoxContext bbCtx (N.BBTemplate t) =
             Just n ->
               case indexMaybe (bbInputs bbCtx) n of
                 Just _ -> Nothing
-                Nothing ->
-                  Just ( "Blackbox required at least " ++ show (n+1)
-                      ++ " arguments, but only " ++ show (length (bbInputs bbCtx))
-                      ++ " were passed." )
+                Nothing -> do
+                  let str = fromJust (fmap Text.unpack (getAp $ prettyElem e))
+                  Just ( "Blackbox used \"" ++ str ++ "\""
+                      ++ ", but only " ++ show (length (bbInputs bbCtx))
+                      ++ " arguments were passed." )
 
 extractLiterals :: BlackBoxContext
                 -> [Expr]
@@ -492,20 +493,20 @@ renderElem b (IF c t f) = do
   syn <- hdlSyn
   enums <- renderEnums
   xOpt <- aggressiveXOptBB
-  let c' = check (coerce xOpt) iw hdl syn enums c
+  c' <- check (coerce xOpt) iw hdl syn enums c
   if c' > 0 then renderTemplate b t else renderTemplate b f
   where
-    check :: Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> Int
+    check :: Backend backend => Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> State backend Int
     check xOpt iw hdl syn enums c' = case c' of
-      (Size e)   -> typeSize (lineToType b [e])
-      (Length e) -> case lineToType b [e] of
+      (Size e)   -> pure $ typeSize (lineToType b [e])
+      (Length e) -> pure $ case lineToType b [e] of
                        (Vector n _)              -> n
                        Void (Just (Vector n _))  -> n
                        (MemBlob n _)             -> n
                        Void (Just (MemBlob n _)) -> n
                        _                         -> 0 -- HACK: So we can test in splitAt if one of the
                               -- vectors in the tuple had a zero length
-      (Lit n) -> case bbInputs b !! n of
+      (Lit n) -> pure $ case bbInputs b !! n of
         (l,_,_)
           | Literal _ l' <- l ->
             case l' of
@@ -533,16 +534,16 @@ renderElem b (IF c t f) = do
           , [Literal _ (NumLit j)] <- extractLiterals bbCtx
           -> fromInteger j
         k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k)
-      (Depth e)  -> case lineToType b [e] of
+      (Depth e)  -> pure $ case lineToType b [e] of
                       (RTree n _) -> n
                       _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type"
-      IW64       -> if iw == 64 then 1 else 0
-      (HdlSyn s) -> if s == syn then 1 else 0
-      (IsVar n)  -> let (e,_,_) = bbInputs b !! n
+      IW64       -> pure $ if iw == 64 then 1 else 0
+      (HdlSyn s) -> pure $ if s == syn then 1 else 0
+      (IsVar n)  -> pure $ let (e,_,_) = bbInputs b !! n
                     in case e of
                       Identifier _ Nothing -> 1
                       _                    -> 0
-      (IsLit n)  -> let (e,_,_) = bbInputs b !! n
+      (IsLit n)  -> pure $ let (e,_,_) = bbInputs b !! n
                     in case e of
                       DataCon {}   -> 1
                       Literal {}   -> 1
@@ -556,13 +557,13 @@ renderElem b (IF c t f) = do
                                                        RenderEnums True  -> 1
                                                        RenderEnums False -> 0
                           isScalar _ _            = 0
-                      in isScalar hdl ty
+                        in pure $ isScalar hdl ty
 
-      (IsUndefined n) ->
+      (IsUndefined n) -> pure $
         let (e, _, _) = bbInputs b !! n
         in if xOpt && checkUndefined e then 1 else 0
 
-      (IsActiveEnable n) ->
+      (IsActiveEnable n) -> pure $
         let (e, ty, _) = bbInputs b !! n in
         case ty of
           Enable _ ->
@@ -584,52 +585,81 @@ renderElem b (IF c t f) = do
           _ ->
             error $ $(curLoc) ++ "IsActiveEnable: Expected Bool or Enable, not: " ++ show ty
 
-      (ActiveEdge edgeRequested n) ->
-        let (_, ty, _) = bbInputs b !! n in
-        case stripVoid ty of
-          KnownDomain _ _ edgeActual _ _ _ ->
+      (ActiveEdge edgeRequested n) -> do
+        let (_, ty, _) = bbInputs b !! n
+        domConf <- getDomainConf ty
+        case domConf of
+          VDomainConfiguration _ _ edgeActual _ _ _ -> pure $
             if edgeRequested == edgeActual then 1 else 0
-          _ ->
-            error $ $(curLoc) ++ "ActiveEdge: Expected `KnownDomain` or `KnownConfiguration`, 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` or `KnownConfiguration`, not: " ++ show ty
-
-      (IsInitDefined n) ->
-        let (_, ty, _) = bbInputs b !! n in
-        case stripVoid ty of
-          KnownDomain _ _ _ _ Defined _ -> 1
-          KnownDomain _ _ _ _ Unknown _ -> 0
-          _ -> error $ $(curLoc) ++ "IsInitDefined: Expected `KnownDomain` or `KnownConfiguration`, 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` or `KnownConfiguration`, not: " ++ show ty
-
-      (StrCmp [Text t1] n) ->
+
+      (IsSync n) -> do
+        let (_, ty, _) = bbInputs b !! n
+        domConf <- getDomainConf ty
+        case domConf of
+          VDomainConfiguration _ _ _ Synchronous _ _ -> pure 1
+          VDomainConfiguration _ _ _ Asynchronous _ _ -> pure 0
+
+      (IsInitDefined n) -> do
+        let (_, ty, _) = bbInputs b !! n
+        domConf <- getDomainConf ty
+        case domConf of
+          VDomainConfiguration _ _ _ _ Defined _ -> pure 1
+          VDomainConfiguration _ _ _ _ Unknown _ -> pure 0
+
+      (IsActiveHigh n) -> do
+        let (_, ty, _) = bbInputs b !! n
+        domConf <- getDomainConf ty
+        case domConf of
+          VDomainConfiguration _ _ _ _ _ ActiveHigh -> pure 1
+          VDomainConfiguration _ _ _ _ _ ActiveLow  -> pure 0
+
+      (StrCmp [Text t1] n) -> pure $
         let (e,_,_) = bbInputs b !! n
         in  case exprToString e of
               Just t2
                 | t1 == Text.pack t2 -> 1
                 | otherwise -> 0
               Nothing -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e
-      (And es)   -> if all (/=0) (map (check xOpt iw hdl syn enums) es)
+      (And es)   -> do
+        es' <- mapM (check xOpt iw hdl syn enums) es
+        pure $ if all (/=0) es'
                        then 1
                        else 0
-      CmpLE e1 e2 -> if check xOpt iw hdl syn enums e1 <= check xOpt iw hdl syn enums e2
-                        then 1
-                        else 0
+      CmpLE e1 e2 -> do
+        v1 <- check xOpt iw hdl syn enums e1
+        v2 <- check xOpt iw hdl syn enums e2
+        if v1 <= v2
+          then pure 1
+          else pure 0
       _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, LIT, DEPTH, IW64, VIVADO, OTHERSYN, ISVAR, ISLIT, ISUNDEFINED, ISACTIVEENABLE, ACTIVEEDGE, ISSYNC, ISINITDEFINED, ISACTIVEHIGH, STRCMP, AND, ISSCALAR or CMPLE."
                              ++ "\nGot: " ++ show c'
 renderElem b e = fmap const (renderTag b e)
 
+getDomainConf :: (Backend backend, HasCallStack) => HWType -> State backend VDomainConfiguration
+getDomainConf = generalGetDomainConf domainConfigurations
+
+generalGetDomainConf
+  :: forall m. (Monad m, HasCallStack)
+  => (m DomainMap) -- ^ a way to get the `DomainMap`
+  -> HWType -> m VDomainConfiguration
+generalGetDomainConf getDomainMap ty = case (snd . stripAttributes . stripVoid) ty of
+  KnownDomain dom period activeEdge resetKind initBehavior resetPolarity ->
+    pure $ VDomainConfiguration (Data.Text.unpack dom) (fromIntegral period) activeEdge resetKind initBehavior resetPolarity
+
+  Clock dom -> go dom
+  ClockN dom -> go dom
+  Reset dom  -> go dom
+  Enable dom -> go dom
+  Product _DiffClock _ [Clock dom,_clkN] -> go dom
+  t -> error $ "Don't know how to get a Domain out of HWType: " <> show t
+ where
+  go :: HasCallStack => N.DomainName -> m VDomainConfiguration
+  go dom = do
+    doms <- getDomainMap
+    case HashMap.lookup dom doms of
+      Nothing -> error $ "Can't find domain " <> show dom <> ". Please report an issue at https://github.com/clash-lang/clash-compiler/issues."
+      Just conf -> pure conf
+
 parseFail :: Text -> BlackBoxTemplate
 parseFail t = case runParse t of
   Failure errInfo ->
diff --git a/clash-lib/src/Clash/Primitives/DSL.hs b/clash-lib/src/Clash/Primitives/DSL.hs
@@ -118,8 +118,8 @@ import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))
 import           Clash.Annotations.SynthesisAttributes (Attr)
 import           Clash.Backend                   hiding (Usage, fromBV, toBV)
 import           Clash.Backend.VHDL              (VHDLState)
-import           Clash.Explicit.Signal           (ResetPolarity(..))
-import           Clash.Netlist.BlackBox.Util     (exprToString, renderElem)
+import           Clash.Explicit.Signal           (ResetPolarity(..), vResetPolarity)
+import           Clash.Netlist.BlackBox.Util     (exprToString, getDomainConf, renderElem)
 import           Clash.Netlist.BlackBox.Types
   (BlackBoxTemplate, Element(Component, Text), Decl(..))
 import qualified Clash.Netlist.Id                as Id
@@ -204,6 +204,17 @@ instance Backend backend => HasIdentifierSet (BlockState backend) where
 instance HasUsageMap backend => HasUsageMap (BlockState backend) where
   usageMap = bsBackend.usageMap
 
+liftToBlockState
+  :: forall backend a. Backend backend
+   => State backend a -> State (BlockState backend) a
+liftToBlockState (StateT f) = StateT g
+ where
+  g :: BlockState backend -> Identity (a, BlockState backend)
+  g sbsIn = do
+    let sIn = _bsBackend sbsIn
+    (res,sOut) <- f sIn
+    pure (res, sbsIn{_bsBackend = sOut})
+
 -- | A typed expression.
 data TExpr = TExpr
   { ety :: HWType
@@ -1012,32 +1023,26 @@ unsafeToActiveHigh
   :: Backend backend
   => Text
   -- ^ Name hint
-  -> HWType
-  -- ^ 'KnownDomain'
   -> TExpr
   -- ^ Reset signal
   -> State (BlockState backend) TExpr
-unsafeToActiveHigh nm dom rExpr =
-  case extrResetPolarity dom of
+unsafeToActiveHigh nm rExpr = do
+  resetLevel <- vResetPolarity <$> liftToBlockState (getDomainConf (ety rExpr))
+  case resetLevel of
     ActiveHigh -> pure rExpr
     ActiveLow -> notExpr nm rExpr
 
-extrResetPolarity :: HWType -> ResetPolarity
-extrResetPolarity (Void (Just (KnownDomain _ _ _ _ _ p))) = p
-extrResetPolarity p = error ("Internal error: expected KnownDomain, got: " <> show p)
-
 -- | Massage a reset to work as active-low reset.
 unsafeToActiveLow
   :: Backend backend
   => Text
   -- ^ Name hint
-  -> HWType
-  -- ^ 'KnownDomain'
   -> TExpr
   -- ^ Reset signal
   -> State (BlockState backend) TExpr
-unsafeToActiveLow nm dom rExpr =
-  case extrResetPolarity dom of
+unsafeToActiveLow nm rExpr = do
+  resetLevel <- vResetPolarity <$> liftToBlockState (getDomainConf (ety rExpr))
+  case resetLevel of
     ActiveLow -> pure rExpr
     ActiveHigh -> notExpr nm rExpr
 
diff --git a/clash-lib/src/Clash/Primitives/Intel/ClockGen.hs b/clash-lib/src/Clash/Primitives/Intel/ClockGen.hs
@@ -36,9 +36,9 @@ import qualified Prettyprinter.Interpolate as I
 data Variant = Altpll | AlteraPll
 
 hdlUsed :: [Int]
-hdlUsed = [ knownDomIn, clk, rst ]
+hdlUsed = [ clk, rst ]
  where
-  knownDomIn
+  _knownDomIn
     :< _clocksClass
     :< _clocksCxt
     :< _numOutClocks
@@ -81,7 +81,7 @@ hdlTemplate ::
   BlackBoxContext ->
   State s Doc
 hdlTemplate variant bbCtx
-  | [ knownDomIn
+  | [ _knownDomIn
     , _clocksClass
     , _clocksCxt
     , _numOutClocks
@@ -110,7 +110,7 @@ hdlTemplate variant bbCtx
 
     DSL.declarationReturn bbCtx (stdName variant <> "_block") $ do
 
-      rstHigh <- DSL.unsafeToActiveHigh "reset" (DSL.ety knownDomIn) rst
+      rstHigh <- DSL.unsafeToActiveHigh "reset" rst
       pllOuts <- DSL.declareN "pllOut" pllOutTys
       locked <- DSL.declare "locked" Bit
       pllLock <- DSL.boolFromBit "pllLock" locked
diff --git a/clash-lib/src/Clash/Primitives/Xilinx/ClockGen.hs b/clash-lib/src/Clash/Primitives/Xilinx/ClockGen.hs
@@ -65,7 +65,7 @@ clockWizardTemplate
   -> BlackBoxContext
   -> State s Doc
 clockWizardTemplate isDifferential bbCtx
-  | [ knownDomIn
+  | [ _knownDomIn
     , _clocksClass
     , _clocksCxt
     , _numOutClocks
@@ -79,7 +79,7 @@ clockWizardTemplate isDifferential bbCtx
       clkWizInstName <- Id.makeBasic $ fromMaybe "clk_wiz" $ bbCtxName bbCtx
       DSL.declarationReturn bbCtx blockName $ do
 
-        rstHigh <- DSL.unsafeToActiveHigh "reset" (DSL.ety knownDomIn) rst
+        rstHigh <- DSL.unsafeToActiveHigh "reset" rst
         pllOuts <- DSL.declareN "pllOut" pllOutTys
         locked <- DSL.declare "locked" Bit
         pllLock <- DSL.boolFromBit "pllLock" locked
diff --git a/clash-prelude/src/Clash/Signal/Internal.hs b/clash-prelude/src/Clash/Signal/Internal.hs
@@ -1279,7 +1279,8 @@ unsafeFromReset (Reset r) = r
 -- __NB__: You probably want to use 'unsafeFromActiveLow' or
 -- 'unsafeFromActiveHigh'.
 unsafeToReset
-  :: Signal dom Bool
+  :: KnownDomain dom
+  => Signal dom Bool
   -> Reset dom
 unsafeToReset r = Reset r
 -- See: https://github.com/clash-lang/clash-compiler/pull/2511
@@ -1359,7 +1360,7 @@ unsafeFromActiveLow r =
       SActiveLow -> r
 
 -- | Invert reset signal
-invertReset :: Reset dom -> Reset dom
+invertReset :: KnownDomain dom => Reset dom -> Reset dom
 invertReset = unsafeToReset . fmap not . unsafeFromReset
 
 infixr 2 .||.
diff --git a/clash-prelude/src/Clash/Tutorial.hs b/clash-prelude/src/Clash/Tutorial.hs
diff --git a/tests/src/Test/Tasty/Clash.hs b/tests/src/Test/Tasty/Clash.hs
