Add Attributes to InstDecl

Allows BlackBox Haskell functions to specify synthesis attributes on
component instantations.

2020-08-20T14_28_50+02_00_my_change_message

@@ -0,0 +1,2 @@
+* New features (API):
+  * [#1482](https://github.com/clash-lang/clash-compiler/pull/1482): Additional field with synthesis attributes added to `InstDecl` in `Clash.Netlist.Types`

clash-cores/src/Clash/Cores/LatticeSemi/Blackboxes/IO.hs

@@ -72,7 +72,7 @@ sbioTemplate bbCtx = do
   getMon $ blockDecl sbio $
     [ NetDecl Nothing dIn0 Bit
     , NetDecl Nothing dIn1 Bit
-    , InstDecl Comp Nothing compName sbio_inst
+    , InstDecl Comp Nothing [] compName sbio_inst
       [ (Identifier "PIN_TYPE" Nothing, BitVector 6, pinConfig)
       ]
       [ -- NOTE: Direction is set to 'In', but will be rendered as inout due to

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

@@ -904,13 +904,16 @@ inst_ (CondAssignment id_ ty scrut scrutTy es) = fmap Just $ do
     conds i ((Nothing,e):_)   = ("default" <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> return []
     conds i ((Just c ,e):es') = (exprLitSV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> conds i es'
 
-inst_ (InstDecl _ _ nm lbl ps pms) = fmap Just $
-    nest 2 (stringS nm <> params <> stringS lbl <> line <> pms' <> semi)
+inst_ (InstDecl _ _ attrs nm lbl ps pms) = fmap Just $
+    attrs' <> nest 2 (stringS nm <> params <> stringS lbl <> line <> pms' <> semi)
   where
     pms' = tupled $ sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,_,e) <- pms]
     params
       | null ps   = space
       | otherwise = line <> "#" <> tupled (sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,e) <- ps]) <> line
+    attrs'
+      | null attrs = emptyDoc
+      | otherwise  = addAttrs attrs line
 
 inst_ (BlackBoxD _ libs imps inc bs bbCtx) =
   fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx)))

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

@@ -190,7 +190,7 @@ instance Backend VHDLState where
                pure decs <>
                if null attrs
                 then emptyDoc
-                else line <> line <> renderAttrs attrs) <> line <>
+                else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> line <>
             nest 2
               ("begin" <> line <>
                 insts ds) <> line <>
@@ -879,7 +879,7 @@ entity c = do
 
     rports p = "port" <> (parens (align (vcat (punctuate semi (pure p))))) <> semi
 
-    rattrs      = renderAttrs attrs
+    rattrs      = renderAttrs (TextS.pack "signal") attrs
     attrs       = inputAttrs ++ outputAttrs
     inputAttrs  = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype]
     outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype]
@@ -895,7 +895,7 @@ architecture c = do {
   ; nest 2
       (("architecture structural of" <+> pretty (componentName c) <+> "is" <> line <>
        decls (declarations c)) <> line <>
-       if null attrs then emptyDoc else line <> line <> renderAttrs attrs) <> line <>
+       if null attrs then emptyDoc else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> line <>
     nest 2
       ("begin" <> line <>
        insts (declarations c)) <> line <>
@@ -964,9 +964,10 @@ attrMap attrs = foldl go empty' attrs
     (typ, (signalName, renderAttr attr) : elems)
 
 renderAttrs
-  :: [(TextS.Text, Attr')]
+  :: TextS.Text
+  -> [(TextS.Text, Attr')]
   -> VHDLM Doc
-renderAttrs (attrMap -> attrs) =
+renderAttrs what (attrMap -> attrs) =
   vcat $ sequence $ intersperse " " $ map renderAttrGroup (assocs attrs)
  where
   renderAttrGroup
@@ -985,9 +986,9 @@ renderAttrs (attrMap -> attrs) =
         "attribute"
     <+> string attrname
     <+> "of"
-    <+> stringS signalName
+    <+> stringS signalName -- or component name
     <+> colon
-    <+> "signal is"
+    <+> stringS what <+> "is" -- "signal is" or "component is"
     <+> string value
     <> semi
 
@@ -1300,24 +1301,25 @@ decls ds = do
     rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds
     case dsDoc of
       [] -> emptyDoc
-      _  -> punctuate' semi (pure dsDoc)
+      _  -> vcat (pure dsDoc)
 
 decl :: Int ->  Declaration -> VHDLM (Maybe (Doc,Int))
 decl l (NetDecl' noteM _ id_ ty iEM) = Just <$> (,fromIntegral (TextS.length id_)) <$>
-  maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty sizedQualTyName ty <> iE)
+  maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty sizedQualTyName ty <> iE <> semi)
   where
     addNote n = mappend ("--" <+> pretty n <> line)
     iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM
 
-decl _ (InstDecl Comp _ nm _ gens pms) = fmap (Just . (,0)) $ do
+decl _ (InstDecl Comp _ attrs nm _ gens pms) = fmap (Just . (,0)) $ do
   { rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> colon <+> portDir dir <+> sizedQualTyName ty | (i,dir,ty,_) <- pms ]
   ; rec (g,lsg) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum lsg) (expr_ False i) <+> colon <+> tyName ty | (i,ty,_) <- gens]
   ; "component" <+> pretty nm <> line <>
     ( if null g then emptyDoc
         else indent 2 ("generic" <> line <> tupledSemi (pure g) <> semi) <> line
     )
     <> indent 2 ("port" <+> tupledSemi (pure p) <> semi) <> line <>
-    "end component"
+    "end component" <> semi <> line
+    <> attrs'
   }
  where
     formalLength (Identifier i _) = fromIntegral (TextS.length i)
@@ -1326,6 +1328,8 @@ decl _ (InstDecl Comp _ nm _ gens pms) = fmap (Just . (,0)) $ do
     portDir In  = "in"
     portDir Out = "out"
 
+    attrs' = if null attrs then emptyDoc else renderAttrs (TextS.pack "component") [(nm, a) | a <- attrs]
+
 decl _ _ = return Nothing
 
 noEmptyInit :: VHDLM Doc -> VHDLM Doc
@@ -1447,7 +1451,7 @@ inst_ (CondAssignment id_ _sig scrut scrutTy es) = fmap Just $
     conds ((Nothing,e):_)   = expr_ False e <+> "when" <+> "others" <:> return []
     conds ((Just c ,e):es') = expr_ False e <+> "when" <+> patLit scrutTy c <:> conds es'
 
-inst_ (InstDecl entOrComp libM nm lbl gens pms) = do
+inst_ (InstDecl entOrComp libM _ nm lbl gens pms) = do
     maybe (return ()) (\lib -> Mon (libraries %= (T.fromStrict lib:))) libM
     fmap Just $
       nest 2 $ pretty lbl <+> colon <> entOrComp'

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

@@ -534,13 +534,16 @@ inst_ (CondAssignment id_ _ scrut scrutTy es) = fmap Just $
     conds i ((Nothing,e):_)   = ("default" <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> return []
     conds i ((Just c ,e):es') = (exprLitV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> conds i es'
 
-inst_ (InstDecl _ _ nm lbl ps pms) = fmap Just $
-    nest 2 (stringS nm <> params <> stringS lbl <> line <> pms' <> semi)
+inst_ (InstDecl _ _ attrs nm lbl ps pms) = fmap Just $
+    attrs' <> nest 2 (stringS nm <> params <> stringS lbl <> line <> pms' <> semi)
   where
     pms' = tupled $ sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,_,e) <- pms]
     params
       | null ps   = space
       | otherwise = line <> "#" <> tupled (sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,e) <- ps]) <> line
+    attrs'
+      | null attrs = emptyDoc
+      | otherwise  = addAttrs attrs line
 
 inst_ (BlackBoxD _ libs imps inc bs bbCtx) =
   fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx)))

clash-lib/src/Clash/Netlist.hs

@@ -639,7 +639,7 @@ mkFunApp dstId fun args tickDecls = do
               instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName
               instLabel2 <- affixName instLabel1
               instLabel3 <- mkUniqueIdentifier Basic instLabel2
-              let instDecl = InstDecl Entity Nothing compName instLabel3 [] (outpAssign ++ inpAssigns)
+              let instDecl = InstDecl Entity Nothing [] compName instLabel3 [] (outpAssign ++ inpAssigns)
               return (argDecls ++ argDecls' ++ tickDecls ++ [instDecl])
             else error [I.i|
               Under-applied normalized function at component #{compName}:

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

@@ -993,7 +993,7 @@ mkFunInput resId e =
                                                 , Identifier "~RESULT" Nothing )
                       i <- varCount <<%= (+1)
                       let instLabel     = TextS.concat [compName,TextS.pack ("_" ++ show i)]
-                          instDecl      = InstDecl Entity Nothing compName instLabel [] (outpAssign:inpAssigns)
+                          instDecl      = InstDecl Entity Nothing [] compName instLabel [] (outpAssign:inpAssigns)
                       return (Right (("",tickDecls ++ [instDecl]),Wire))
                     Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e
             C.Lam {} -> do

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

@@ -280,6 +280,7 @@ data Declaration
   | InstDecl
       EntityOrComponent                  -- FIELD Whether it's an entity or a component
       (Maybe Comment)                    -- FIELD Comment to add to the generated code
+      [Attr']                            -- FIELD Attributes to add to the generated code
       !Identifier                        -- FIELD The component's (or entity's) name
       !Identifier                        -- FIELD Instance label
       [(Expr,HWType,Expr)]               -- FIELD List of parameters for this component (param name, param type, param value)

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

@@ -1513,6 +1513,7 @@ mkTopUnWrapper topEntity annM man dstId args tickDecls = do
       InstDecl
         Entity
         (Just topName)
+        []
         topName
         instLabel3
         []

clash-lib/src/Clash/Primitives/DSL.hs

@@ -618,7 +618,7 @@ instDecl entOrComp compName instLbl attrs inPorts outPorts = do
   inPorts' <- mapM (mkPort In) inPorts
   outPorts' <- mapM (mkPort Out) outPorts
 
-  addDeclaration $ InstDecl entOrComp Nothing compName instLbl (mkAttrs attrs) (inPorts' ++ outPorts')
+  addDeclaration $ InstDecl entOrComp Nothing [] compName instLbl (mkAttrs attrs) (inPorts' ++ outPorts')
     where
     mkPort inOrOut (nm, pExpr) = do
       TExpr ty pExpr' <- toIdentifier (nm <> "_port")  pExpr

clash-lib/src/Clash/Primitives/Intel/ClockGen.hs

@@ -85,7 +85,7 @@ alteraPllTemplate bbCtx = do
   [[ NetDecl Nothing locked  rstTy
    , NetDecl' Nothing Reg pllLock (Right Bool) Nothing]
   ,[ NetDecl Nothing clkNm ty | (clkNm,ty) <- zip clocks tys]
-  ,[ InstDecl Comp Nothing compName alteraPll_inst [] $ concat
+  ,[ InstDecl Comp Nothing [] compName alteraPll_inst [] $ concat
       [[(Identifier "refclk" Nothing,In,clkTy,clk)
        ,(Identifier "rst" Nothing,In,rstTy,rst)]
       ,[(Identifier (TextS.pack ("outclk_" ++ show n)) Nothing,Out,ty,Identifier k Nothing)
@@ -122,7 +122,7 @@ altpllTemplate bbCtx = do
   [ NetDecl Nothing locked  Bit
   , NetDecl' Nothing Reg pllLock (Right Bool) Nothing
   , NetDecl Nothing pllOut clkOutTy
-  , InstDecl Comp Nothing compName alteraPll_inst []
+  , InstDecl Comp Nothing [] compName alteraPll_inst []
       [(Identifier "clk" Nothing,In,clkTy,clk)
       ,(Identifier "areset" Nothing,In,rstTy,rst)
       ,(Identifier "c0" Nothing,Out,clkOutTy,Identifier pllOut Nothing)

tests/shouldwork/Basic/Parameters.hs

@@ -40,7 +40,7 @@ myAddTemplate bbCtx = do
   let [_, (xExp, xTy, _), (yExp, yTy, _)] = bbInputs bbCtx
       (resExp, resTy) = bbResult bbCtx
   getMon $ blockDecl "my_add_block"
-    [ InstDecl Comp Nothing "my_add" "my_add_inst"
+    [ InstDecl Comp Nothing [] "my_add" "my_add_inst"
         [ (Identifier "size" Nothing, Integer, Literal Nothing (NumLit . fromIntegral $ typeSize xTy))
         ]
         [ (Identifier "x" Nothing, In, xTy, xExp)

tests/shouldwork/Issues/T1388.hs

@@ -53,7 +53,7 @@ assertNoSLVInPortMap =
   mapM_ goDecl . declarations
  where
   goDecl :: Declaration -> IO ()
-  goDecl (InstDecl _ _ _ _ _ ps)
+  goDecl (InstDecl _ _ _ _ _ _ ps)
     | all goPort ps = pure ()
     | otherwise = error ("Not all ports have simple modifiers: " <> show ps)
   goDecl _ = pure ()

tests/shouldwork/Netlist/NoDeDup.hs

@@ -44,7 +44,7 @@ topEntity n abcd = (f n abcd) - (g n abcd)
 testPath :: FilePath
 testPath = "tests/shouldwork/Netlist/NoDeDup.hs"
 
-isTwiceInst (InstDecl Entity Nothing "twice" _ _ _) = True
+isTwiceInst (InstDecl Entity Nothing [] "twice" _ _ _) = True
 isTwiceInst _ = False
 
 assertNumTwiceInsts :: Component -> IO ()

tests/shouldwork/SynthesisAttributes/InstDeclAnnotations.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module InstDeclAnnotations where
+
+import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))
+import           Clash.Backend
+import           Clash.Core.Var                  (Attr' (..))
+import           Clash.Netlist.Id
+import           Clash.Netlist.Types
+import           Clash.Prelude
+import           Control.Monad.State
+import           GHC.Stack
+import           Data.List                       (isInfixOf)
+import           Data.String.Interpolate         (i)
+import           Data.String.Interpolate.Util    (unindent)
+import           Data.Semigroup.Monad            (getMon)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import           Data.Text.Prettyprint.Doc.Extra (Doc (..))
+import qualified Prelude as P
+import           System.Environment              (getArgs)
+
+
+myTF :: TemplateFunction
+myTF = TemplateFunction used valid myTemplate
+ where
+  used    = []
+  valid _ = True
+
+myTemplate
+  :: Backend s
+  => BlackBoxContext
+  -> State s Doc
+myTemplate bbCtx = do
+  blkName  <- mkUniqueIdentifier Basic "blkName"
+  compInst <- mkUniqueIdentifier Basic "test_inst"
+  let
+    compName = "TEST"
+    attrs =
+      [ IntegerAttr' "my_int_attr"    7
+      , StringAttr'  "my_string_attr" "Hello World!"
+      ]
+  getMon
+    $ blockDecl blkName [InstDecl Comp Nothing attrs compName compInst [] [] ]
+
+
+myBlackBox
+  :: Signal System Int
+  -> Signal System Int
+myBlackBox _ = pure (errorX "not implemented")
+{-# NOINLINE myBlackBox #-}
+{-# ANN myBlackBox (InlinePrimitive [VHDL,Verilog,SystemVerilog] $ unindent [i|
+   [ { "BlackBox" :
+        { "name" : "InstDeclAnnotations.myBlackBox",
+          "kind" : "Declaration",
+          "format": "Haskell",
+          "templateFunction": "InstDeclAnnotations.myTF"
+        }
+     }
+   ]
+   |]) #-}
+
+
+topEntity
+  :: SystemClockResetEnable
+  => Signal System Int
+  -> Signal System Int
+topEntity = myBlackBox
+
+
+--------------- Actual tests for generated HDL -------------------
+assertIn :: String -> String -> IO ()
+assertIn needle haystack
+  | needle `isInfixOf` haystack = return ()
+  | otherwise                   = P.error $ P.concat [ "Expected:\n\n  ", needle
+                                                     , "\n\nIn:\n\n", haystack ]
+
+-- VHDL test
+mainVHDL :: IO ()
+mainVHDL = do
+  [topFile] <- getArgs
+  content <- P.readFile topFile
+
+  assertIn "attribute my_int_attr : integer;" content
+  assertIn "attribute my_int_attr of TEST : component is 7;" content
+
+  assertIn "attribute my_string_attr : string;" content
+  assertIn "attribute my_string_attr of TEST : component is \"Hello World!\";" content
+
+-- Verilog test
+mainVerilog :: IO ()
+mainVerilog = do
+  [topFile] <- getArgs
+  content <- P.readFile topFile
+
+  assertIn "(* my_int_attr = 7, my_string_attr = \"Hello World!\" *)" content
+
+-- Verilog and SystemVerilog should share annotation syntax
+mainSystemVerilog = mainVerilog
+

testsuite/Main.hs

@@ -573,6 +573,7 @@ runClashTest = defaultMain $ clashTestRoot
       , clashTestGroup "SynthesisAttributes"
         [ NEEDS_PRIMS_GHC(outputTest ("tests" </> "shouldwork" </> "SynthesisAttributes") allTargets [] [] "Simple" "main")
         , NEEDS_PRIMS_GHC(outputTest ("tests" </> "shouldwork" </> "SynthesisAttributes") allTargets [] [] "Product" "main")
+        ,                 outputTest ("tests" </> "shouldwork" </> "SynthesisAttributes") allTargets [] [] "InstDeclAnnotations" "main"
         , NEEDS_PRIMS_GHC(runTest "Product" def)
         ]
       , clashTestGroup "Testbench"