diff --git a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs b/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs index 3ea6cd2613..1ae5d1874b 100644 --- a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs +++ b/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 diff --git a/tests/Main.hs b/tests/Main.hs index efe8ba4657..baf7871d5d 100755 --- a/tests/Main.hs +++ b/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 diff --git a/tests/shouldwork/PrimitiveGuards/MultipleGuards.hs b/tests/shouldwork/PrimitiveGuards/MultipleGuards.hs new file mode 100644 index 0000000000..67318a7851 --- /dev/null +++ b/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