Add 'RenderVoid' option to blackboxes

Void data (e.g., `Index 1`, `BitVector 0`, `()`) results in zero-width
vectors in HDL. HDL tools handle these constructs poorly. To work around
that 01843d3 added void-filtering to
Clash. As a consequence, any functions solely generating a void
construct aren't rendered at all. Often, this is okay: functions
yielding voids are generally the result of a generalization and don't
perform any actually work when instantiated with a void. _Sometimes_
though, we would like to generate them:

 * In the case of `BiSignal`s, one would like to completely remove any
   `BiSignalOut`s from the HDL, as the corresponding `BiSignalIn` will
   already be converted to an `inout` wire.

 * (SystemVerilog) Assertions don't carry any "out" signals. They
   construct a comment instructing the simulator / verification tool to
   check some property. Clash simulation can't support this though:
   functions without outputs simply do not exist. In this case, we'd
   like to mark an "assertion result" as void, so it would get filtered
   in HDL. See #864 for more information.

 * Some `IO ()` actions as described in #815 must result in HDL. Like
   the previous two features, `IO ()` would get filtered though.

This commit allows blackboxes to specify whether they would like to be
rendered even if their result is void. Note that any blackboxes
specifying this must make sure that they do not assign anything to
their result - as this is zero bits, Clash won't generate any signal
declarations for it.

As a happy coincidence, this removes the need for special support for
BiSignalOut in the compiler.

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

@@ -199,7 +199,7 @@ checkPrimitive :: CompiledPrimMap -> GHC.CoreBndr -> C2C ()
 checkPrimitive primMap v = do
   nm <- qualifiedNameString (GHC.varName v)
   case HashMap.lookup nm primMap of
-    Just (extractPrim -> Just (BlackBox _ _ _ _ _ _ _ _ inc r ri templ)) -> do
+    Just (extractPrim -> Just (BlackBox _ _ _ _ _ _ _ _ _ inc r ri templ)) -> do
       let
         info = GHC.idInfo v
         inline = GHC.inlinePragmaSpec $ GHC.inlinePragInfo info

clash-lib/prims/systemverilog/Clash_Signal_BiSignal.json

@@ -1,6 +1,7 @@
 [ { "BlackBox" :
     { "name" : "Clash.Signal.BiSignal.writeToBiSignal#",
       "kind" : "Declaration",
+      "renderVoid": "RenderVoid",
       "type" :
 "writeToBiSignal#
   :: HasCallStack                   -- ARG[0]

clash-lib/prims/verilog/Clash_Signal_BiSignal.json

@@ -1,6 +1,7 @@
 [ { "BlackBox" :
     { "name" : "Clash.Signal.BiSignal.writeToBiSignal#",
       "kind" : "Declaration",
+      "renderVoid": "RenderVoid",
       "type" :
 "writeToBiSignal#
   :: HasCallStack                   -- ARG[0]

clash-lib/prims/vhdl/Clash_Signal_BiSignal.json

@@ -1,6 +1,7 @@
 [ { "BlackBox" :
     { "name" : "Clash.Signal.BiSignal.writeToBiSignal#",
       "kind" : "Declaration",
+      "renderVoid": "RenderVoid",
       "type" :
 "writeToBiSignal#
   :: HasCallStack                   -- ARG[0]

clash-lib/src/Clash/Driver.hs

@@ -409,14 +409,15 @@ compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf bbGenName source
     go args Nothing = do
       loadImportAndInterpret idirs args topDir qualMod funcName "BlackBoxFunction"
 
-compilePrimitive idirs pkgDbs topDir (BlackBox pNm wf tkind () oReg libM imps fPlural incs rM riM templ) = do
+compilePrimitive idirs pkgDbs topDir
+  (BlackBox pNm wf rVoid tkind () oReg libM imps fPlural incs rM riM templ) = do
   libM'  <- mapM parseTempl libM
   imps'  <- mapM parseTempl imps
   incs'  <- mapM (traverse parseBB) incs
   templ' <- parseBB templ
   rM'    <- traverse parseBB rM
   riM'   <- traverse parseBB riM
-  return (BlackBox pNm wf tkind () oReg libM' imps' fPlural incs' rM' riM' templ')
+  return (BlackBox pNm wf rVoid tkind () oReg libM' imps' fPlural incs' rM' riM' templ')
  where
   iArgs = concatMap (("-package-db":) . (:[])) pkgDbs
 

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

@@ -341,7 +341,7 @@ mkPrimitive bbEParen bbEasD dst (nm,pinfo) args ty tickDecls =
               -- Blackbox template generation succesful. Rerun 'go', but this time
               -- around with a 'normal' @BlackBox@
               go (P.BlackBox
-                    bbName wf bbKind () bbOutputReg bbLibrary bbImports
+                    bbName wf bbRenderVoid bbKind () bbOutputReg bbLibrary bbImports
                     bbFunctionPlurality bbIncludes Nothing Nothing bbTemplate)
         p@P.BlackBox {} ->
           case kind p of
@@ -356,7 +356,18 @@ mkPrimitive bbEParen bbEasD dst (nm,pinfo) args ty tickDecls =
                   let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)
                                            (includes p) templ bbCtx
                   return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])
-                Nothing -> return (Identifier "__VOID__" Nothing,[])
+
+                -- Render declarations as a Noop when requested
+                Nothing | RenderVoid <- renderVoid p -> do
+                  let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TDECL_NOOP__" 0)
+                  (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst1 args
+                  (templ,templDecl) <- prepareBlackBox pNm tempD bbCtx
+                  let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)
+                                           (includes p) templ bbCtx
+                  return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])
+
+                -- Otherwise don't render them
+                Nothing -> return (Identifier "__VOID_TDECL__" Nothing,[])
             TExpr -> do
               let tempE = template p
                   pNm = name p
@@ -372,7 +383,18 @@ mkPrimitive bbEParen bbEasD dst (nm,pinfo) args ty tickDecls =
                                                    (includes p) bbTempl bbCtx
                                                    bbEParen)
                       return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ templDecl ++ [tmpAssgn])
-                    Nothing -> return (Identifier "__VOID__" Nothing,[])
+
+                    -- Render expression as a Noop when requested
+                    Nothing | RenderVoid <- renderVoid p -> do
+                      let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRD_NOOP__" 0)
+                      (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst1 args
+                      (templ,templDecl) <- prepareBlackBox pNm tempE bbCtx
+                      let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)
+                                               (includes p) templ bbCtx
+                      return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])
+
+                    -- Otherwise don't render them
+                    Nothing -> return (Identifier "__VOID_TEXPRD__" Nothing,[])
                 else do
                   resM <- resBndr False dst
                   case resM of
@@ -392,6 +414,16 @@ mkPrimitive bbEParen bbEasD dst (nm,pinfo) args ty tickDecls =
                               | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> []
                             _ -> templDecl0
                       return (BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen,ctxDcls ++ templDecl1)
+                    -- Render expression as a Noop when requested
+                    Nothing | RenderVoid <- renderVoid p -> do
+                      let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRE_NOOP__" 0)
+                      (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst1 args
+                      (templ,templDecl) <- prepareBlackBox pNm tempE bbCtx
+                      let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)
+                                               (includes p) templ bbCtx
+                      return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])
+
+                    -- Otherwise don't render them
                     Nothing -> return (Identifier "__VOID__" Nothing,[])
         P.Primitive pNm _ _
           | pNm == "GHC.Prim.tagToEnum#" -> do
@@ -443,24 +475,29 @@ mkPrimitive bbEParen bbEasD dst (nm,pinfo) args ty tickDecls =
       -> (Either Identifier Id)
       -> NetlistMonad (Maybe (Id,Identifier,[Declaration]))
       -- Nothing when the binder would have type `Void`
-    resBndr mkDec dst' = case dst' of
-      Left dstL -> case mkDec of
-        False -> do
-          -- TODO: check that it's okay to use `mkUnsafeSystemName`
-          let nm' = mkUnsafeSystemName dstL 0
-              id_ = mkLocalId ty nm'
-          return (Just (id_,dstL,[]))
-        True -> do
-          nm1 <- extendIdentifier Extended dstL "_res"
-          nm2 <- mkUniqueIdentifier Extended nm1
-          -- TODO: check that it's okay to use `mkUnsafeInternalName`
-          let nm3 = mkUnsafeSystemName nm2 0
-              id_ = mkLocalId ty nm3
-          idDeclM <- mkNetDecl (id_,mkApps (Prim nm pinfo) args)
-          case idDeclM of
-            Nothing     -> return Nothing
-            Just idDecl -> return (Just (id_,nm2,[idDecl]))
-      Right dstR -> return (Just (dstR,nameOcc . varName $ dstR,[]))
+    resBndr mkDec dst' = do
+      resHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty
+      if isVoid resHwTy then
+        pure Nothing
+      else
+        case dst' of
+          Left dstL -> case mkDec of
+            False -> do
+              -- TODO: check that it's okay to use `mkUnsafeSystemName`
+              let nm' = mkUnsafeSystemName dstL 0
+                  id_ = mkLocalId ty nm'
+              return (Just (id_,dstL,[]))
+            True -> do
+              nm1 <- extendIdentifier Extended dstL "_res"
+              nm2 <- mkUniqueIdentifier Extended nm1
+              -- TODO: check that it's okay to use `mkUnsafeInternalName`
+              let nm3 = mkUnsafeSystemName nm2 0
+                  id_ = mkLocalId ty nm3
+              idDeclM <- mkNetDecl (id_,mkApps (Prim nm pinfo) args)
+              case idDeclM of
+                Nothing     -> return Nothing
+                Just idDecl -> return (Just (id_,nm2,[idDecl]))
+          Right dstR -> return (Just (dstR,nameOcc . varName $ dstR,[]))
 
 -- | Create an template instantiation text and a partial blackbox content for an
 -- argument term, given that the term is a function. Errors if the term is not

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

@@ -25,9 +25,11 @@ module Clash.Netlist.BlackBox.Types
  , Element(..)
  , Decl(..)
  , HdlSyn(..)
+ , RenderVoid(..)
  ) where
 
 import                Control.DeepSeq            (NFData)
+import                Data.Aeson                 (FromJSON)
 import                Data.Binary                (Binary)
 import                Data.Hashable              (Hashable)
 import                Data.Text.Lazy             (Text)
@@ -41,6 +43,15 @@ import {-# SOURCE #-} Clash.Netlist.Types
 
 import qualified      Clash.Signal.Internal      as Signal
 
+-- | Whether this primitive should be rendered when its result type is void.
+-- Defaults to 'NoRenderVoid'.
+data RenderVoid
+  = RenderVoid
+  -- ^ Render blackbox, even if result type is void
+  | NoRenderVoid
+  -- ^ Don't render blackbox result type is void. Default for all blackboxes.
+  deriving (Show, Generic, NFData, Binary, Hashable, FromJSON)
+
 data TemplateKind
   = TDecl
   | TExpr
@@ -55,12 +66,13 @@ data BlackBoxMeta =
                , bbImports :: [BlackBoxTemplate]
                , bbFunctionPlurality :: [(Int, Int)]
                , bbIncludes :: [((S.Text, S.Text), BlackBox)]
+               , bbRenderVoid :: RenderVoid
                }
 
 -- | Use this value in your blackbox template function if you do want to
 -- accept the defaults as documented in @Clash.Primitives.Types.BlackBox@.
 emptyBlackBoxMeta :: BlackBoxMeta
-emptyBlackBoxMeta = BlackBoxMeta False TExpr [] [] [] []
+emptyBlackBoxMeta = BlackBoxMeta False TExpr [] [] [] [] NoRenderVoid
 
 -- | A BlackBox function generates a blackbox template, given the inputs and
 -- result type of the function it should provide a blackbox for. This is useful

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

@@ -15,6 +15,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE ViewPatterns        #-}
 
 module Clash.Netlist.BlackBox.Util where
 
@@ -55,7 +56,7 @@ import           Clash.Netlist.Types             (BlackBoxContext (..),
                                                   Modifier (..),
                                                   Declaration(BlackBoxD))
 import qualified Clash.Netlist.Types             as N
-import           Clash.Netlist.Util              (typeSize)
+import           Clash.Netlist.Util              (typeSize, isVoid)
 import           Clash.Signal.Internal
   (ResetKind(..), ResetPolarity(..), InitBehavior(..))
 import           Clash.Util
@@ -102,13 +103,13 @@ verifyBlackBoxContext bbCtx (N.BBTemplate t) =
       case e of
         Lit n ->
           case indexMaybe (bbInputs bbCtx) n of
-            Just (inp, _, False) ->
+            Just (inp, isVoid -> False, False) ->
               Just ( "Argument " ++ show n ++ " should be literal, as blackbox "
                   ++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp)
             _ -> Nothing
         Const n ->
           case indexMaybe (bbInputs bbCtx) n of
-            Just (inp, _, False) ->
+            Just (inp, isVoid -> False, False) ->
               Just ( "Argument " ++ show n ++ " should be literal, as blackbox "
                   ++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp)
             _ -> Nothing
@@ -989,6 +990,7 @@ walkElement f el = maybeToList (f el) ++ walked
 -- | Determine variables used in an expression. Used for VHDL sensitivity list.
 -- Also see: https://github.com/clash-lang/clash-compiler/issues/365
 usedVariables :: Expr -> [Identifier]
+usedVariables Noop              = []
 usedVariables (Identifier i _)  = [i]
 usedVariables (DataCon _ _ es)  = concatMap usedVariables es
 usedVariables (DataTag _ e')    = [either id id e']

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

@@ -331,6 +331,8 @@ data Expr
       !Bool                    -- FIELD Wrap in paretheses?
   | ConvBV     (Maybe Identifier) HWType Bool Expr
   | IfThenElse Expr Expr Expr
+  -- | Do nothing
+  | Noop
   deriving Show
 
 -- | Literals used in an expression

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

@@ -106,12 +106,6 @@ isVoid _       = False
 isFilteredVoid :: FilteredHWType -> Bool
 isFilteredVoid = isVoid . stripFiltered
 
-isBiSignalOut :: HWType -> Bool
-isBiSignalOut (Void (Just (BiDirectional Out _))) = True
-isBiSignalOut (Vector n ty) | n /= 0              = isBiSignalOut ty
-isBiSignalOut (RTree _ ty)                        = isBiSignalOut ty
-isBiSignalOut _                                   = False
-
 mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
 mkIdentifier typ nm = Lens.use mkIdentifierFn <*> pure typ <*> pure nm
 

clash-lib/src/Clash/Normalize/Transformations.hs

@@ -751,7 +751,7 @@ removeUnusedExpr :: HasCallStack => NormRewrite
 removeUnusedExpr _ e@(collectArgsTicks -> (p@(Prim nm pInfo),args,ticks)) = do
   bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives)
   case bbM of
-    Just (extractPrim ->  Just (BlackBox pNm _ _ _ _ _ _ _ inc r ri templ)) -> do
+    Just (extractPrim ->  Just (BlackBox pNm _ _ _ _ _ _ _ _ inc r ri templ)) -> do
       let usedArgs | isFromInt pNm
                    = [0,1,2]
                    | nm `elem` ["Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"

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

@@ -39,7 +39,7 @@ import {-# SOURCE #-} Clash.Netlist.Types
 import           Clash.Annotations.Primitive  (PrimitiveGuard)
 import           Clash.Core.Term (WorkInfo (..))
 import           Clash.Netlist.BlackBox.Types
-  (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..))
+  (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..), RenderVoid(..))
 import           Control.Applicative          ((<|>))
 import           Control.DeepSeq              (NFData)
 import           Data.Aeson
@@ -142,6 +142,9 @@ data Primitive a b c d
     -- ^ Name of the primitive
   , workInfo  :: WorkInfo
     -- ^ Whether the primitive does any work, i.e. takes chip area
+  , renderVoid :: RenderVoid
+    -- ^ Whether this primitive should be rendered when its result type is
+    -- void. Defaults to 'NoRenderVoid'.
   , kind      :: TemplateKind
     -- ^ Whether this results in an expression or a declaration
   , warning  :: c
@@ -226,6 +229,7 @@ instance FromJSON UnresolvedPrimitive where
           "BlackBox"  ->
             BlackBox <$> conVal .: "name"
                      <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable
+                     <*> conVal .:? "renderVoid" .!= NoRenderVoid
                      <*> (conVal .: "kind" >>= parseTemplateKind)
                      <*> conVal .:? "warning"
                      <*> conVal .:? "outputReg" .!= False

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

@@ -96,7 +96,7 @@ resolvePrimitive' _metaPath (Primitive name wf primType) =
   return (name, HasBlackBox (Primitive name wf primType))
 resolvePrimitive' metaPath BlackBox{template=t, includes=i, resultName=r, resultInit=ri, ..} = do
   let resolveSourceM = traverse (traverse (resolveTemplateSource metaPath))
-  bb <- BlackBox name workInfo kind () outputReg libraries imports functionPlurality
+  bb <- BlackBox name workInfo renderVoid kind () outputReg libraries imports functionPlurality
           <$> mapM (traverse resolveSourceM) i
           <*> traverse resolveSourceM r
           <*> traverse resolveSourceM ri

clash-lib/src/Clash/Util.hs

@@ -217,6 +217,11 @@ traceIf True  msg = trace msg
 traceIf False _   = id
 {-# INLINE traceIf #-}
 
+-- | A version of 'concatMap' that works with a monadic predicate.
+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
+concatMapM f as = concat <$> sequence (map f as)
+{-# INLINE concatMapM #-}
+
 -- | Monadic version of 'Data.List.partition'
 partitionM :: Monad m
            => (a -> m Bool)

tests/shouldwork/BlackBox/ZeroWidth.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE BangPatterns #-}
+
+module ZeroWidth where
+
+import qualified Prelude                      as P
+import           Control.Monad                (forM_)
+import           Clash.Annotations.Primitive
+import           Clash.Prelude
+import           GHC.Exts
+import           Data.String.Interpolate      (i)
+import           Data.String.Interpolate.Util (unindent)
+import           Data.List                    (isInfixOf)
+import           System.Environment           (getArgs)
+import           System.FilePath              ((</>), takeDirectory)
+
+
+luckyNumber, question, answer :: String
+luckyNumber = "Your lucky number is 3552664958674928."
+question = "What lies on the bottom of the ocean and twitches?"
+answer = "A nervous wreck."
+
+
+-- | Inserts given comment in HDL. Returns "nothing".
+comment :: String -> ()
+comment !_s = ()
+{-# NOINLINE comment #-}
+{-# ANN comment (InlinePrimitive VHDL $ unindent [i|
+  [ { "BlackBox" :
+      { "name"      : "ZeroWidth.comment"
+      , "kind"      : "Declaration"
+      , "renderVoid": "RenderVoid"
+      , "template"  : "~NAME[0]"
+      }
+    }
+  ] |]
+  ) #-}
+
+implicitComment :: Int -> ()
+implicitComment n =
+  case n of
+    5 -> ()
+    _ ->
+      comment question
+{-# NOINLINE implicitComment #-}
+
+topEntity :: Int -> (Int, (), ())
+topEntity a = (succ a, comment luckyNumber, implicitComment a)
+
+mainHDL :: String -> String -> IO ()
+mainHDL topFile implFile = do
+  [topDir] <- getArgs
+  contentTopEntity <- readFile (takeDirectory topDir </> topFile)
+  contentImplicitComment <- readFile (takeDirectory topDir </> implFile)
+
+  if luckyNumber `isInfixOf` contentTopEntity then
+    pure ()
+  else
+    error $ "Expected:\n\n" P.++ luckyNumber
+       P.++ "\n\nBut did not find it in:\n\n" P.++ contentTopEntity
+
+  if question `isInfixOf` contentImplicitComment then
+    pure ()
+  else
+    error $ "Expected:\n\n" P.++ question
+       P.++ "\n\nBut did not find it in:\n\n" P.++ contentImplicitComment
+
+mainSystemVerilog, mainVerilog, mainVHDL :: IO ()
+mainSystemVerilog = error "NYI"
+mainVerilog       = error "NYI"
+mainVHDL          = mainHDL "topentity.vhdl" "implicitcomment.vhdl"