Merge pull request #2547 from clash-lang/add-mark-debug

Add `Clash.Annotations.SynthesisAttributes.markDebug` (plus an unfortunate amount of baggage)

changelog/2023-07-16T13_33_18+02_00_add_annotate

@@ -0,0 +1 @@
+ADDED: `Clash.Annotations.SynthesisAttributes.annotate`: a term level way of annotating signals with synthesis attributes

changelog/2023-07-16T13_34_31+02_00_add_markDebug

@@ -0,0 +1 @@
+ADDED: `Clash.Annotations.SynthesisAttributes.markDebug`: a way of marking a signals "debug", instructing synthesizers to leave the signal alone and offer debug features

clash-cores/src/Clash/Cores/Xilinx/VIO/Internal/BlackBoxes.hs

@@ -38,8 +38,8 @@ import Control.Exception (assert)
 
 import qualified Clash.Netlist.Id as Id
 import qualified Clash.Primitives.DSL as DSL
+import Clash.Annotations.SynthesisAttributes (Attr(StringAttr))
 import Clash.Backend (Backend)
-import Clash.Core.Var (Attr' (StringAttr'))
 import Clash.Netlist.Expr (bits, fromBits)
 import Clash.Netlist.Types
   ( Size
@@ -202,7 +202,7 @@ vioProbeBBTF bbCtx
  where
   -- The HDL attribute 'KEEP' is added to the signals connected to the
   -- probe ports so they are not optimized away by the synthesis tool.
-  keepAttrs = [StringAttr' "KEEP" "true"]
+  keepAttrs = [StringAttr "KEEP" "true"]
 
   toNameCheckedBv nameHint inProbe =
     fmap (checkNameCollision nameHint) $

clash-ghc/clash-ghc.cabal

@@ -180,6 +180,7 @@ library
                       uniplate                  >= 1.6.12   && < 1.8,
                       reflection                >= 2.1.2    && < 3.0,
                       primitive                 >= 0.5.0.1  && < 1.0,
+                      string-interpolate        ^>= 0.3,
                       template-haskell          >= 2.8.0.0  && < 2.21,
                       utf8-string               >= 1.0.0.0  && < 1.1.0.0,
                       vector                    >= 0.11     && < 1.0

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

@@ -10,7 +10,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -34,6 +36,8 @@ where
 
 -- External Modules
 import           Control.Lens                ((^.), (%~), (&), (%=), (.~), view, makeLenses)
+import           Control.Applicative         ((<|>))
+import           Control.Monad.Extra         (ifM, andM)
 import           Control.Monad.RWS.Strict    (RWS)
 import qualified Control.Monad.RWS.Strict    as RWS
 import           Data.Bifunctor              (second)
@@ -48,6 +52,7 @@ import           Data.Text                   (Text, pack)
 import qualified Data.Text                   as Text
 import           Data.Text.Encoding          (decodeUtf8)
 import qualified Data.Traversable            as T
+import           Data.String.Interpolate     (__i)
 import qualified Text.Read                   as Text
 #if MIN_VERSION_ghc(9,4,0)
 import           Data.Primitive.ByteArray    (ByteArray(ByteArray))
@@ -180,6 +185,7 @@ import VarSet     (isEmptyVarSet)
 
 -- Local imports
 import           Clash.Annotations.Primitive (extractPrim)
+import           Clash.Annotations.SynthesisAttributes (Annotate, Attr(..))
 import qualified Clash.Core.DataCon          as C
 import qualified Clash.Core.Literal          as C
 import qualified Clash.Core.Name             as C
@@ -190,7 +196,7 @@ import qualified Clash.Core.Util             as C (undefinedTy, undefinedXPrims)
 import qualified Clash.Core.Var              as C
 import qualified Clash.Data.UniqMap          as C
 import           Clash.Normalize.Primitives  as C
-import           Clash.Primitives.Types
+import           Clash.Primitives.Types      hiding (name)
 import           Clash.Util
 import           Clash.GHC.Util
 
@@ -856,9 +862,6 @@ typeConstructorToString
 typeConstructorToString constructor =
    Text.unpack . C.nameOcc <$> coreToName tyConName tyConUnique qualifiedNameString constructor
 
-_ATTR_NAME :: String
-_ATTR_NAME = "Clash.Annotations.SynthesisAttributes.Attr"
-
 -- | Flatten a list type structure to a list of types.
 listTypeToListOfTypes :: Type -> [Type]
 -- TyConApp ': [kind, head, tail]
@@ -886,115 +889,104 @@ tyLitToString (LitTy (StrTyLit s)) = unpackFS s
 tyLitToString s = error $ unwords [ "Could not unpack given type to string:"
                                   , showPprUnsafe s ]
 
+-- | Returns string in Text form of (LitTy (StrTyLit s)) construction.
+tyLitToText :: Type -> Text
+tyLitToText = Text.pack . tyLitToString
+
 -- | Returns integer of (LitTy (NumTyLit n)) construction.
 tyLitToInteger :: Type -> Integer
 tyLitToInteger (LitTy (NumTyLit n)) = n
 tyLitToInteger s = error $ unwords [ "Could not unpack given type to integer:"
                                    , showPprUnsafe s ]
 
 -- | Try to interpret a Type as an Attr
-coreToAttr
-  :: Type
-  -> C2C C.Attr'
-coreToAttr t@(TyConApp ty args) = do
-  let key   = args !! 0
-  let value = args !! 1
-  name' <- typeConstructorToString ty
+coreToAttr :: Type -> C2C (Attr Text)
+coreToAttr t0@(TyConApp ty args) = do
+  name <- typeConstructorToString ty
   envs <- view famInstEnvs
+  let
+    -- XXX: This relies on 'value' not being evaluated if the constructor
+    --      doesn't have a second field.
+    key = args !! 1
+    value = args !! 2
 #if MIN_VERSION_ghc(9,4,0)
   let Reduction _ key1 = normaliseType envs Nominal key
       Reduction _ value1 = normaliseType envs Nominal value
 #else
   let (_,key1) = normaliseType envs Nominal key
       (_,value1) = normaliseType envs Nominal value
 #endif
-  case name' of
-    "Clash.Annotations.SynthesisAttributes.StringAttr" ->
-        return $ C.StringAttr' (tyLitToString key1) (tyLitToString value1)
-    "Clash.Annotations.SynthesisAttributes.IntegerAttr" ->
-        return $ C.IntegerAttr' (tyLitToString key1) (tyLitToInteger value1)
-    "Clash.Annotations.SynthesisAttributes.BoolAttr" -> do
-        bool <- boolTypeToBool value1
-        return $ C.BoolAttr' (tyLitToString key1) bool
-    "Clash.Annotations.SynthesisAttributes.Attr" ->
-        return $ C.Attr' (tyLitToString key1)
-    _ ->
-        case coreView t of
-          Just t' -> coreToAttr t'
-          Nothing -> error $ unwords [ "Expected StringAttr, IntegerAttr, BoolAttr or Attr"
-                       , "constructor, got:" ++ name' ]
-
-coreToAttr t =
-  error $ unwords [ "Expected type constructor (TyConApp), but got:"
-                  , showPprUnsafe t ]
-
-coreToAttrs'
-    :: [Type]
-    -> C2C [C.Attr']
-coreToAttrs' [annotationType, realType, attributes] = allAttrs
+  if
+    | name == show 'StringAttr ->
+      return $ StringAttr (tyLitToText key1) (tyLitToText value1)
+    | name == show 'IntegerAttr ->
+      return $ IntegerAttr (tyLitToText key1) (tyLitToInteger value1)
+    | name == show 'BoolAttr -> do
+      bool <- boolTypeToBool value1
+      return $ BoolAttr (tyLitToText key1) bool
+    | name == show 'Attr ->
+      return $ Attr (tyLitToText key1)
+    | otherwise ->
+      case coreView t0 of
+        Just t1 -> coreToAttr t1
+        Nothing -> error $ [__i|Expected constructor of Attr, got #{name}|]
+coreToAttr t0 =
+  case coreView t0 of
+    Just t1 -> coreToAttr t1
+    Nothing -> error $ [__i|Expected constructor of Attr, got #{showPprUnsafe t0}|]
+
+coreToAttrs' :: [Type] -> C2C [Attr Text]
+coreToAttrs' [k, a, attrs] = do
+  -- We expect three type arguments:
+  --
+  --  k: either @Attr@ or @[Attr]@
+  --  a: type being annotated
+  --  attrs: attribute or list of attributes
+  --
+  attrs1 <- tryList
+  attrs2 <- tryAttr
+  case attrs1 <|> attrs2 of
+    Just theseAttrs -> do
+      subAttrs <- coreToAttrs a
+      pure (theseAttrs <> subAttrs)
+    Nothing ->
+      error [__i|
+        Expected either an attribute or a list of attributes, got:
+
+          #{showPprUnsafe k}
+      |]
  where
-  allAttrs = (++) <$> attrs <*> subAttrs
-
-  subAttrs =
-    coreToAttrs realType
-
-  attrs =
-    case annotationType of
-      TyConApp ty [TyConApp ty' _args'] -> do
-        name'  <- typeConstructorToString ty
-        name'' <- typeConstructorToString ty'
-
-        let result | name' `elem` ["GHC.Types.[]", "GHC.Types.List"] && name'' == _ATTR_NAME =
-                      -- List of attributes
-                      traverse coreToAttr (listTypeToListOfTypes attributes)
-
-                   | name' `elem` ["GHC.Types.[]", "GHC.Types.List"] =
-                      -- List, but unknown types
-                      error $ $(curLoc) ++ unwords [ "Annotate expects an"
-                                                   , "Attr or a list of"
-                                                   , "Attr's, but got a list"
-                                                   , "of:", name'']
-                   | otherwise =
-                        -- Some unknown nested type
-                      error $ $(curLoc) ++ unwords [ "Annotate expects an"
-                                                   , "Attr or a list of"
-                                                   , "Attr's, but got:"
-                                                   , name' ]
-
-        result
-
-      TyConApp ty _args -> do
-        name' <- typeConstructorToString ty
-        if name' == _ATTR_NAME
-          then
-            -- Single annotation
-            sequence [coreToAttr attributes]
-          else do
-            -- Annotation to something we don't recognize (not a list,
-            -- nor an Attr)
-            tystr <- typeConstructorToString ty
-            error $ unwords [ "Annotate expects an Attr or a list of Attr's,"
-                            , "but got:", tystr ]
-      _ ->
-        error $ $(curLoc) ++ unwords [ "Expected TyConApp, not:"
-                                     , showPprUnsafe annotationType]
+
+  isListTy = fmap (== show ''[]) . typeConstructorToString
+  isAttrTy = fmap (== show ''Attr) . typeConstructorToString
+
+  tryList = case k of
+    TyConApp ty0 [TyConApp ty1 _] -> do
+      ifM
+        (andM [isListTy ty0, isAttrTy ty1])
+        (Just <$> traverse coreToAttr (listTypeToListOfTypes attrs))
+        (pure Nothing)
+    _ -> pure Nothing
+
+  tryAttr = case k of
+    TyConApp ty _ -> do
+      ifM
+        (isAttrTy ty)
+        (Just <$> sequence [coreToAttr attrs])
+        (pure Nothing)
+    _ -> pure Nothing
 
 coreToAttrs' illegal =
-  error $ "Expected list with three items (as Annotate has three arguments), but got: "
-      ++ show (map (showPprUnsafe) illegal)
+  error $ "Unexpected type args to Annotate: " ++ show (map (showPprUnsafe) illegal)
 
 -- | If this type has an annotate type synonym, return list of attributes.
-coreToAttrs
-  :: Type
-  -> C2C [C.Attr']
+coreToAttrs :: Type -> C2C [Attr Text]
 coreToAttrs (TyConApp tycon kindsOrTypes) = do
   name' <- typeConstructorToString tycon
 
-  if name' == "Clash.Annotations.SynthesisAttributes.Annotate"
-    then
-      coreToAttrs' kindsOrTypes
-    else
-      return []
+  if name' == show ''Annotate
+  then coreToAttrs' kindsOrTypes
+  else return []
 
 coreToAttrs _ =
     return []

clash-lib-hedgehog/src/Clash/Hedgehog/Core/Var.hs

@@ -7,37 +7,24 @@ Random generation of core variables.
 -}
 
 module Clash.Hedgehog.Core.Var
-  ( genAttr'
-  , genTyVar
+  ( genTyVar
   , genId
   , genLocalId
   , genGlobalId
   , genVars
   ) where
 
-import Hedgehog (MonadGen, Range)
+import Hedgehog (MonadGen)
 import qualified Hedgehog.Gen as Gen
 
 import Clash.Core.Name (Name(nameUniq))
 import Clash.Core.Term (TmName)
 import Clash.Core.Type (Kind, KindOrType, TyName, Type)
-import Clash.Core.Var (Attr'(..), Id, IdScope(..), TyVar, Var(..))
+import Clash.Core.Var (Id, IdScope(..), TyVar, Var(..))
 import qualified Clash.Data.UniqMap as UniqMap
 
 import Clash.Hedgehog.Core.Name (genFreshName)
 
-genAttr' :: forall m. MonadGen m => Range Int -> m Attr'
-genAttr' range =
-  Gen.choice
-    [ BoolAttr' <$> genAlphaNum <*> Gen.bool
-    , IntegerAttr' <$> genAlphaNum <*> genInteger
-    , StringAttr' <$> genAlphaNum <*> genAlphaNum
-    , Attr' <$> genAlphaNum
-    ]
- where
-  genAlphaNum = Gen.string range Gen.alphaNum
-  genInteger  = toInteger <$> Gen.integral range
-
 -- | Generate a fresh type variable of the specified kind.
 genTyVar :: forall m. MonadGen m => Kind -> m TyName -> m TyVar
 genTyVar kn genName = do

clash-lib/clash-lib.cabal

@@ -276,6 +276,7 @@ Library
                       Clash.Primitives.Types
                       Clash.Primitives.Util
 
+                      Clash.Primitives.Annotations.SynthesisAttributes
                       Clash.Primitives.GHC.Int
                       Clash.Primitives.GHC.Literal
                       Clash.Primitives.GHC.Word

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

@@ -49,7 +49,7 @@ import           Clash.Annotations.BitRepresentation.ClashLib
   (bitsToBits)
 import           Clash.Annotations.BitRepresentation.Util
   (BitOrigin(Lit, Field), bitOrigins, bitRanges)
-import           Clash.Core.Var                       (Attr'(..))
+import           Clash.Annotations.SynthesisAttributes (Attr(..))
 import           Clash.Debug                          (traceIf)
 import           Clash.Backend
 import           Clash.Backend.Verilog
@@ -702,23 +702,23 @@ decl (NetDecl' noteM id_ tyE iEM) =
 decl _ = return Nothing
 
 -- | Convert single attribute to systemverilog syntax
-renderAttr :: Attr' -> Text.Text
-renderAttr (StringAttr'  key value) = Text.pack $ concat [key, " = ", show value]
-renderAttr (IntegerAttr' key value) = Text.pack $ concat [key, " = ", show value]
-renderAttr (BoolAttr'    key True ) = Text.pack $ concat [key, " = ", "1"]
-renderAttr (BoolAttr'    key False) = Text.pack $ concat [key, " = ", "0"]
-renderAttr (Attr'        key      ) = Text.pack $ key
+renderAttr :: Attr TextS.Text -> TextS.Text
+renderAttr (StringAttr  key value) = TextS.concat [key, " = ", TextS.pack (show value)]
+renderAttr (IntegerAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)]
+renderAttr (BoolAttr    key True ) = TextS.concat [key, " = ", "1"]
+renderAttr (BoolAttr    key False) = TextS.concat [key, " = ", "0"]
+renderAttr (Attr        key      ) = key
 
 -- | Add attribute notation to given declaration
 addAttrs
-  :: [Attr']
+  :: [Attr TextS.Text]
   -> SystemVerilogM Doc
   -> SystemVerilogM Doc
 addAttrs []     t = t
 addAttrs attrs' t =
   "(*" <+> attrs'' <+> "*)" <+> t
     where
-      attrs'' = string $ Text.intercalate ", " (map renderAttr attrs')
+      attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs')
 
 insts :: [Declaration] -> SystemVerilogM Doc
 insts [] = emptyDoc