Allow binders to have multiple PrimitiveGuard annotations

Fixes #1436

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

@@ -29,7 +29,7 @@ where
 #endif
 
 -- External Modules
-import           Clash.Annotations.Primitive     (HDL, PrimitiveGuard)
+import           Clash.Annotations.Primitive     (HDL, PrimitiveGuard(..))
 import           Clash.Annotations.TopEntity     (TopEntity (..))
 import           Clash.Primitives.Types          (UnresolvedPrimitive)
 import           Clash.Util                      (ClashException(..), pkgIdFromTypeable)
@@ -39,6 +39,7 @@ import           Control.Exception               (SomeException, throw)
 import           Control.Monad                   (forM, join, when)
 import           Data.List.Extra                 (nubSort)
 import           Control.Exception               (throwIO)
+import           Control.Monad                   (foldM)
 #if MIN_VERSION_ghc(9,0,0)
 import           Control.Monad.Catch             as MC (try)
 #endif
@@ -786,19 +787,38 @@ errOnDuplicateAnnotations
   -> [[a]]
   -- ^ Parsed annotations
   -> [(CoreSyn.CoreBndr, a)]
-errOnDuplicateAnnotations nm bndrs anns =
+errOnDuplicateAnnotations nm =
+  combineAnnotationsWith err nm
+ where
+  err _ _ = Left $ "A binder can't have more than one '" ++ nm ++ "' annotation."
+
+combineAnnotationsWith
+  :: forall a. (a -> a -> Either String a)
+  -- ^ function to (attempts to) combine different annotations
+  -> String
+  -- ^ Name of annotation
+  -> [CoreSyn.CoreBndr]
+  -- ^ Binders searched for
+  -> [[a]]
+  -- ^ Parsed annotations
+  -> [(CoreSyn.CoreBndr, a)]
+combineAnnotationsWith f nm bndrs anns =
   go (zip bndrs anns)
  where
-  go
-    :: [(CoreSyn.CoreBndr, [a])]
-    -> [(CoreSyn.CoreBndr, a)]
+  go :: [(CoreSyn.CoreBndr, [a])] -> [(CoreSyn.CoreBndr, a)]
   go []             = []
   go ((_, []):ps)   = go ps
-  go ((b, [p]):ps)  = (b, p) : (go ps)
-  go ((b, _):_)  =
-    Panic.pgmError $ "The following value has multiple "
-                  ++ "'" ++ nm ++ "' annotations: "
-                  ++ Outputable.showSDocUnsafe (ppr b)
+  go ((b, (a:as)):ps) = case foldM f a as of
+    Left err ->
+      Panic.pgmError $ "Error processing '" ++ nm ++ "' annotations on "
+                       ++ Outputable.showSDocUnsafe (pprQualified $ Var.varName b)
+                       ++ ":\n" ++ err
+    Right x -> (b, x) : go ps
+  pprQualified :: Name.Name -> Outputable.SDoc
+  pprQualified x = case Name.nameModule_maybe x of
+    Just m  -> Outputable.hcat [ppr m, Outputable.dot, ppr x]
+    Nothing -> ppr x
+
 
 -- | Find annotations by given targets
 findAnnotationsByTargets
@@ -849,8 +869,14 @@ findPrimitiveGuardAnnotations
   -> m [(Text.Text, (PrimitiveGuard ()))]
 findPrimitiveGuardAnnotations bndrs = do
   anns0 <- findNamedAnnotations bndrs
-  let anns1 = errOnDuplicateAnnotations "PrimitiveGuard" bndrs anns0
+  let anns1 = combineAnnotationsWith combinePrimGuards "PrimitiveGuard" bndrs anns0
   pure (map (first (qualifiedNameString' . Var.varName)) anns1)
+ where
+  combinePrimGuards a b = case (a,b) of
+    (HasBlackBox x _, HasBlackBox y _) -> Right (HasBlackBox (x++y) ())
+    (DontTranslate  , DontTranslate)   -> Right DontTranslate
+    (_,_) -> Left "One binder can't have both HasBlackBox and DontTranslate annotations."
+
 
 -- | Find annotations of type @DataReprAnn@ and convert them to @DataRepr'@
 findCustomReprAnnotations

tests/Main.hs

@@ -872,6 +872,10 @@ runClashTest = defaultMain $ clashTestRoot
             hdlTargets=[VHDL]
           , expectClashFail=Just (NoTestExitCode, "You shouldn't use 'primitive'!")
           }
+        , runTest "MultipleGuards" def{
+            hdlTargets=[VHDL]
+          , expectClashFail=Just (NoTestExitCode, "You should know that ...")
+          }
         ]
       , clashTestGroup "PrimitiveReductions"
         [ runTest "Lambda" def

tests/shouldwork/PrimitiveGuards/MultipleGuards.hs

@@ -0,0 +1,22 @@
+module MultipleGuards where
+import Clash.Prelude
+import Clash.Annotations.Primitive
+import Clash.Util.Interpolate (i)
+import Data.String.Interpolate (__i)
+
+test :: Bool
+test = True
+{-# NOINLINE test #-}
+{-# ANN test hasBlackBox #-}
+{-# ANN test (warnAlways "WARN1") #-}
+{-# ANN test (warnAlways "WARN2: You should know that ...") #-}
+{-# ANN test (warnAlways "WARN3") #-}
+{-# ANN test (InlineYamlPrimitive [VHDL] $  [__i|
+  BlackBox:
+    name: MultipleGuards.test
+    kind: Expression
+    template: "true"
+ |]) #-}
+
+topEntity :: Bool
+topEntity = test