Add annotateReg

benchmark/profiling/run/profile-netlist-run.hs

@@ -12,6 +12,7 @@ import           Clash.Netlist
 import           Clash.Netlist.Types          hiding (backend, hdlDir)
 
 import           Clash.GHC.NetlistTypes       (ghcTypeToHWType)
+import           Clash.GHC.PartialEval        (ghcEvaluator)
 
 import           Control.DeepSeq              (deepseq)
 import           Data.Binary                  (decode)
@@ -62,7 +63,7 @@ benchFile idirs src = do
                          Clash.Backend.name hdlState' </>
                          takeWhile (/= '.') topEntityS
   (netlist,_,_) <-
-    genNetlist env False transformedBindings topEntityMap compNames
+    genNetlist env ghcEvaluator False transformedBindings topEntityMap compNames
                (ghcTypeToHWType (opt_intWidth (envOpts env)))
                ite (SomeBackend hdlState') seen hdlDir prefixM topEntity
   netlist `deepseq` putStrLn ".. done\n"

changelog/2025-11-21T14_41_29+01_00_add_annotate_reg

@@ -0,0 +1 @@
+ADDED: `Clash.Annotation.SynthesisAtrributes.annotateReg`, a function to add synthesis attributes (e.g. `ASYNC_REG`) to register declarations in the HDL generated by the Clash compiler.

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

@@ -436,6 +436,9 @@ coreToTerm primMap unlocs = term
           -- xToErrorCtx :: forall a. String -> a -> a
           | [_ty, _msg, x] <- args
           = term x
+        go "Clash.Annotations.SynthesisAttributes.annotateReg" args
+          | [ Type nTy, _domTy, _aTy, attrs, x] <- args
+          = C.Tick <$> (C.Attributes <$> coreToType nTy <*> term attrs) <*> term x
         go nm args
           | Just n <- parseBundle "bundle" nm
             -- length args = domain tyvar + signal arg + number of type vars
@@ -615,6 +618,8 @@ coreToTerm primMap unlocs = term
               -> return (nameModTerm C.SetName xType)
               | f == "Clash.XException.xToErrorCtx"
               -> return (xToErrorCtxTerm xType)
+              | f == "Clash.Annotations.SynthesisAttributes.annotateReg"
+              -> return (annotateRegTerm xType)
               | x `elem` unlocs
               -> return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding))
               | otherwise
@@ -1518,6 +1523,36 @@ xToErrorCtxTerm (C.ForAllTy aTV funTy)
 
 xToErrorCtxTerm ty = error $ $(curLoc) ++ show ty
 
+-- | Given the type
+--
+-- > forall n dom a . Vec n (Attr String) -> Signal dom a -> Signal dom a
+--
+-- Generate the term:
+--
+-- > /\(n:Nat) (dom:Symbol) (a:Type).\(attrs:Vec n (Attr String)) (x:Signal dom a).<TICK attrs> x
+annotateRegTerm
+  :: C.Type
+  -> C.Term
+annotateRegTerm (C.ForAllTy nTV (C.ForAllTy domTV (C.ForAllTy aTV funTy)))
+  | C.FunTy attrTy rTy <- C.tyView funTy
+  , C.FunTy xTy _ <- C.tyView rTy
+  = let
+      -- Safe to use `mkUnsafeSystemName` here, because we're building the
+      -- identity \x.x, so any shadowing of 'x' would be the desired behavior.
+      xName            = C.mkUnsafeSystemName "x" 0
+      xId              = C.mkLocalId xTy xName
+      attrName         = C.mkUnsafeSystemName "attrs" 1
+      attrId           = C.mkLocalId attrTy attrName
+    in
+      C.TyLam nTV (
+      C.TyLam domTV (
+      C.TyLam aTV (
+      C.Lam   attrId (
+      C.Lam   xId (
+      C.Tick (C.Attributes (C.VarTy nTV) (C.Var attrId)) (C.Var xId))))))
+
+annotateRegTerm ty = error ($(curLoc) ++ show ty)
+
 isDataConWrapId :: Id -> Bool
 isDataConWrapId v = case idDetails v of
   DataConWrapId {} -> True

clash-lib/prims/common/Clash_Annotations_SynthesisAttributes.primitives.yaml

@@ -0,0 +1,3 @@
+- Primitive:
+    name: Clash.Annotations.SynthesisAttributes.annotateReg
+    primType: Function

clash-lib/src/Clash/Core/FreeVars.hs

@@ -281,6 +281,8 @@ termFreeVars' interesting f = go IntSet.empty where
 
   goTick inLocalScope = \case
     NameMod m ty -> NameMod m <$> typeFreeVars' interesting inLocalScope f ty
+    Attributes ty tm -> Attributes <$> typeFreeVars' interesting inLocalScope f ty
+                                   <*> go inLocalScope tm
     tick         -> pure tick
 
 -- | Get the free variables of an expression and count the number of occurrences

clash-lib/src/Clash/Core/Pretty.hs

@@ -342,6 +342,7 @@ instance PrettyPrec TickInfo where
   pprPrec prec (NameMod SetName t)    = ("<setName>" <>) <$> pprPrec prec t
   pprPrec _    DeDup                  = pure "<deDup>"
   pprPrec _    NoDeDup                = pure "<noDeDup>"
+  pprPrec prec (Attributes _ attrs)   = ("<attributes>" <>) <$> pprPrec prec attrs
 
 instance PrettyPrec SrcSpan where
   pprPrec _ sp = return ("<src>"<>pretty (GHC.showSDocUnsafe (GHC.ppr sp)))

clash-lib/src/Clash/Core/Subst.hs

@@ -56,6 +56,7 @@ module Clash.Core.Subst
     -- * Alpha equivalence
   , aeqType
   , aeqTerm
+  , acmpTerm
     -- * Structural equivalence
   , eqTerm
   , eqType
@@ -584,6 +585,7 @@ substTm doc subst = go where
   goTick (NameMod m ty) = NameMod m (substTy subst ty)
   goTick t@DeDup        = t
   goTick t@NoDeDup      = t
+  goTick (Attributes ty tm) = Attributes (substTy subst ty) (go tm)
 
 -- | Substitute within a case-alternative
 substAlt

clash-lib/src/Clash/Core/Subst.hs-boot

@@ -3,6 +3,7 @@
 module Clash.Core.Subst where
 
 import GHC.Stack (HasCallStack)
+import {-# SOURCE #-} Clash.Core.Term (Term)
 import {-# SOURCE #-} Clash.Core.Type (Type)
 import Clash.Core.Var (TyVar)
 
@@ -20,3 +21,7 @@ aeqType
 
 instance Eq Type
 instance Ord Type
+
+acmpTerm :: Term -> Term -> Ordering
+
+instance Eq Term

clash-lib/src/Clash/Core/Term.hs

@@ -81,7 +81,7 @@ import SrcLoc                                  (SrcSpan, leftmost_smallest)
 import Clash.Core.DataCon                      (DataCon)
 import Clash.Core.Literal                      (Literal)
 import Clash.Core.Name                         (Name (..))
-import {-# SOURCE #-} Clash.Core.Subst         () -- instance Eq/Ord Type
+import {-# SOURCE #-} Clash.Core.Subst         (acmpTerm) -- instance Eq/Ord Type, Eq Term
 import {-# SOURCE #-} Clash.Core.Type          (Type)
 import Clash.Core.Var                          (Var, Id, TyVar)
 import Clash.Util                              (curLoc, thenCompare)
@@ -124,19 +124,25 @@ data TickInfo
   | NoDeDup
   -- ^ Do not deduplicate, i.e. /keep/, an expression inside a case-alternative;
   -- do not try to share expressions between multiple branches.
+  | Attributes Type Term
+  -- ^ Synthesis attributes brough into scope by
+  -- 'Clash.Annotations.SynthesisAttributes.annotateReg'
   deriving (Eq, Show, Generic, NFData, Binary)
 
 instance Ord TickInfo where
   compare (SrcSpan s1) (SrcSpan s2) = leftmost_smallest s1 s2
   compare (NameMod m1 t1) (NameMod m2 t2) =
     compare m1 m2 `thenCompare` compare t1 t2
+  compare (Attributes t1 a1) (Attributes t2 a2) =
+    compare t1 t2 `thenCompare` acmpTerm a1 a2
   compare t1 t2 = compare (getRank t1) (getRank t2)
     where
       getRank :: TickInfo -> Word
-      getRank SrcSpan{} = 0
-      getRank NameMod{} = 1
-      getRank DeDup     = 2
-      getRank NoDeDup   = 3
+      getRank SrcSpan{}     = 0
+      getRank NameMod{}     = 1
+      getRank DeDup         = 2
+      getRank NoDeDup       = 3
+      getRank Attributes {} = 4
 
 -- | Tag to indicate which instance/register name modifier was used
 data NameMod

clash-lib/src/Clash/Core/TermLiteral.hs

@@ -129,6 +129,7 @@ instance TermLiteral Word where
 instance TermLiteral Integer where
   termToData (Tick _ e) = termToData e
   termToData (Literal (IntegerLiteral n)) = Right n
+  termToData (collectArgs -> (_, [Left (Literal (IntLiteral n))])) = Right n
   termToData (collectArgs -> (_, [Left (Literal (IntegerLiteral n))])) = Right n
   termToData t = Left t
 

clash-lib/src/Clash/Driver.hs

@@ -450,7 +450,7 @@ generateHDL env design hdlState typeTrans peEval eval mainTopEntity startTime =
       (topComponent, netlist) <- modifyMVar seenV $ \seen -> do
         (topComponent, netlist, seen') <-
           -- TODO My word, this has far too many arguments.
-          genNetlist env isTb transformedBindings topEntityMap compNames
+          genNetlist env peEval isTb transformedBindings topEntityMap compNames
             typeTrans ite (SomeBackend hdlState') seen hdlDir prefixM topEntity
 
         pure (seen', (topComponent, netlist))

clash-lib/src/Clash/Netlist.hs

@@ -84,11 +84,13 @@ import           Clash.Netlist.Util
 import           Clash.Primitives.Types           as P
 import           Clash.Util
 import qualified Clash.Util.Interpolate           as I
+import Clash.Core.PartialEval (Evaluator)
 
 -- | Generate a hierarchical netlist out of a set of global binders with
 -- @topEntity@ at the top.
 genNetlist
   :: ClashEnv
+  -> Evaluator
   -> Bool
   -- ^ Whether this we're compiling a testbench (suppresses certain warnings)
   -> BindingMap
@@ -113,9 +115,9 @@ genNetlist
   -> Id
   -- ^ Name of the @topEntity@
   -> IO (Component, ComponentMap, IdentifierSet)
-genNetlist env isTb globals tops topNames typeTrans ite be seen0 dir prefixM topEntity = do
+genNetlist env eval isTb globals tops topNames typeTrans ite be seen0 dir prefixM topEntity = do
   ((_meta, topComponent), s) <-
-    runNetlistMonad env isTb globals tops typeTrans ite be seen1 dir componentNames_
+    runNetlistMonad env eval isTb globals tops typeTrans ite be seen1 dir componentNames_
       $ genComponent topEntity
   return (topComponent, _components s, seen1)
  where
@@ -125,6 +127,7 @@ genNetlist env isTb globals tops topNames typeTrans ite be seen0 dir prefixM top
 -- | Run a NetlistMonad action in a given environment
 runNetlistMonad
   :: ClashEnv
+  -> Evaluator
   -> Bool
   -- ^ Whether this we're compiling a testbench (suppresses certain warnings)
   -> BindingMap
@@ -147,8 +150,8 @@ runNetlistMonad
   -> NetlistMonad a
   -- ^ Action to run
   -> IO (a, NetlistState)
-runNetlistMonad env isTb s tops typeTrans ite be seenIds_ dir componentNames_
-  = flip runReaderT (NetlistEnv env "" "" Nothing)
+runNetlistMonad env eval isTb s tops typeTrans ite be seenIds_ dir componentNames_
+  = flip runReaderT (NetlistEnv env "" "" Nothing [] eval)
   . flip runStateT s'
   . runNetlist
   where
@@ -308,8 +311,13 @@ genComponentT compName0 componentExpr = do
       return (ComponentMeta wereVoids sp ids u, component)
 
 mkNetDecl :: (Id, Term) -> NetlistMonad [Declaration]
-mkNetDecl (id_,tm) = preserveVarEnv $ do
-  hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf id_)
+mkNetDecl (id_,tm) | (_,_,ticks) <- collectArgsTicks tm = preserveVarEnv $ withTicks ticks $ \_ -> do
+
+  lAttrs <- Lens.view localAttrs
+  hwTy0 <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf id_)
+  let hwTy = case hwTy0 of
+        Annotated attrs hty0 -> Annotated (attrs ++ lAttrs) hty0
+        hty0 -> annotated lAttrs hty0
 
   if | not (shouldRenderDecl hwTy tm) -> return []
      | (Prim pInfo@PrimInfo{primMultiResult=MultiResult}, args) <- collectArgs tm ->
@@ -356,16 +364,16 @@ mkNetDecl (id_,tm) = preserveVarEnv $ do
 
     -- Set the initialization value of a signal when a primitive wants to set it
     getResInits :: (Id, Term) -> NetlistMonad [Expr]
-    getResInits (i,collectArgsTicks -> (k,args0,ticks)) = case k of
+    getResInits (i,collectArgs -> (k,args0)) = case k of
       Prim p -> extractPrimWarnOrFail (primName p) >>= go p
       _ -> return []
      where
-      go pInfo (BlackBox {resultInits=nmDs, multiResult=True}) = withTicks ticks $ \_ -> do
+      go pInfo (BlackBox {resultInits=nmDs, multiResult=True}) = do
         tcm <- Lens.view tcCache
         let (args1, res) = splitMultiPrimArgs (multiPrimInfo' tcm pInfo) args0
         (bbCtx, _) <- mkBlackBoxContext (primName pInfo) Concurrent res args1
         mapM (go' (primName pInfo) bbCtx) nmDs
-      go pInfo (BlackBox {resultInits=nmDs}) = withTicks ticks $ \_ -> do
+      go pInfo (BlackBox {resultInits=nmDs}) = do
         (bbCtx, _) <- mkBlackBoxContext (primName pInfo) Concurrent [i] args0
         mapM (go' (primName pInfo) bbCtx) nmDs
       go _ _ = pure []

clash-lib/src/Clash/Netlist/Types.hs

@@ -75,6 +75,7 @@ import Clash.Annotations.Primitive          (HDL(..))
 import Clash.Annotations.TopEntity          (TopEntity)
 import Clash.Backend                        (Backend, HasUsageMap (..))
 import Clash.Core.HasType
+import Clash.Core.PartialEval               (Evaluator)
 import Clash.Core.Type                      (Type)
 import Clash.Core.Var                       (Id)
 import Clash.Core.TyCon                     (TyConMap)
@@ -283,6 +284,11 @@ data NetlistEnv
   -- ^ Postfix for instance/register names
   , _setName :: Maybe Text
   -- ^ (Maybe) user given instance/register name
+  , _localAttrs :: [Attr Text]
+  -- ^ Synthesis attributes brough into scope by
+  -- 'Clash.Annotations.SynthesisAttributes.annotateReg'
+  , _peEvaluator :: Evaluator
+  -- ^ Evaluator to evaluate a term to Normal Form
   }
 
 data ComponentMeta = ComponentMeta