introduce WorkIdentity Int [Int] and corresponding inlineIdentity…

changelog/2021-08-12T12_30_00+02_00_collapse_noops.md

@@ -0,0 +1,10 @@
+ADDED: `collapseRHSNoops` inlining stage and `WorkIdentity` constructor.
+
+It is now possible to define primitives to be identical to one of their arguments via the newly introduced `WorkIdentity` constructor.
+This constructor effectivly marks a primitve to be a noop, which further can be conditioned upon multiple of its arguments being noops themselves.
+For an example see `Clash.Sized.Vector.map`.
+
+There is a new inlining stage `collapseRHSNoops` which runs just before `inlineCleanup`.
+It will find noop-primitives defined in such way and `unsafeCoerce#` them to their identity argument.
+
+The goal of all of this is to prevent redundant HDL output. (See Issue #779)

clash-lib/prims/commonverilog/Clash_Sized_Internal_BitVector.primitives

@@ -34,15 +34,15 @@
   }
 , { "BlackBox" :
     { "name"      : "Clash.Sized.Internal.BitVector.pack#"
-    , "workInfo"  : "Never"
+    , "workInfo"  : "Identity 0 []"
     , "kind"      : "Expression"
     , "type"      : "pack# :: Bit -> BitVector 1"
     , "template"  : "~ARG[0]"
     }
   }
 , { "BlackBox" :
     { "name"      : "Clash.Sized.Internal.BitVector.unpack#"
-    , "workInfo"  : "Never"
+    , "workInfo"  : "Identity 0 []"
     , "kind"      : "Expression"
     , "type"      : "unpack# :: BitVector 1 -> Bit"
     , "template"  : "~ARG[0]"

clash-lib/prims/verilog/Clash_Sized_Vector.primitives

@@ -98,7 +98,7 @@ end
   }
 , { "BlackBox" :
     { "name"      : "Clash.Sized.Vector.map"
-    , "workInfo"  : "Never"
+    , "workInfo"  : "Identity 1 [0]"
     , "kind"      : "Declaration"
     , "type"      : "map :: (a -> b) -> Vec n a -> Vec n b"
     , "template"  :

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

@@ -155,6 +155,10 @@ data WorkInfo
   | WorkAlways
   -- ^ Performs work regardless of whether the variables are constant or
   -- variable; these are things like clock or reset generators
+  | WorkIdentity Int [Int]
+  -- ^ A more restrictive version of 'WorkNever', where the value is the
+  -- argument at the given position if all arguments for the given list of
+  -- positions are also 'WorkIdentity'
   deriving (Eq,Show,Generic,NFData,Hashable,Binary)
 
 -- | Term reference

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

@@ -50,6 +50,7 @@ module Clash.Core.Type
   , findFunSubst
   , reduceTypeFamily
   , undefinedTy
+  , unsafeCoerceTy
   , isIntegerTy
   , normalizeType
   , varAttrs
@@ -663,6 +664,14 @@ undefinedTy =
       aTv = (TyVar aNm 0 liftedTypeKind)
   in  ForAllTy aTv (VarTy aTv)
 
+unsafeCoerceTy :: Type
+unsafeCoerceTy =
+  let aNm = mkUnsafeSystemName "a" 0
+      aTv = TyVar aNm 0 liftedTypeKind
+      bNm = mkUnsafeSystemName "b" 1
+      bTv = TyVar bNm 1 liftedTypeKind
+  in ForAllTy aTv (ForAllTy bTv (mkFunTy (VarTy aTv) (VarTy bTv)))
+
 isIntegerTy :: Type -> Bool
 isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == getKey integerTyConKey
 isIntegerTy _ = False

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

@@ -428,6 +428,14 @@ primCo
   -> Term
 primCo ty = Prim (PrimInfo "_CO_" ty WorkNever SingleResult)
 
+-- | Make an unsafe coercion
+primUCo :: Term
+primUCo =
+  Prim PrimInfo { primName        = "GHC.Prim.unsafeCoerce#"
+                , primType        = unsafeCoerceTy
+                , primWorkInfo    = WorkNever
+                , primMultiResult = SingleResult }
+
 substArgTys
   :: DataCon
   -> [Type]

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

@@ -55,6 +55,8 @@ normalization =
     cse        = topdownR (apply "CSE" simpleCSE)
     xOptim     = bottomupR (apply "xOptimize" xOptimize)
     cleanup    = topdownR (apply "etaExpandSyn" etaExpandSyn) >->
+                 -- See [Note] relation `collapseRHSNoops` and `inlineCleanup`
+                 topdownSucR (apply "collapseRHSNoops" collapseRHSNoops) >->
                  topdownSucR (apply "inlineCleanup" inlineCleanup) !->
                  innerMost (applyMany [("caseCon"        , caseCon)
                                       ,("bindConstantVar", bindConstantVar)

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

@@ -24,6 +24,7 @@ module Clash.Normalize.Transformations.Inline
   , inlineCast
   , inlineCleanup
   , inlineHO
+  , collapseRHSNoops
   , inlineNonRep
   , inlineOrLiftNonRep
   , inlineSimIO
@@ -33,8 +34,10 @@ module Clash.Normalize.Transformations.Inline
 
 import qualified Control.Lens as Lens
 import qualified Control.Monad as Monad
-import Control.Monad.Writer (listen)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Writer ((>=>),lift,listen)
 import Data.Default (Default(..))
+import Data.Either  (lefts)
 import qualified Data.HashMap.Lazy as HashMap
 import qualified Data.List as List
 import qualified Data.Maybe as Maybe
@@ -60,12 +63,12 @@ import Clash.Core.Name (Name(..), NameSort(..))
 import Clash.Core.Pretty (PrettyOptions(..), showPpr, showPpr')
 import Clash.Core.Subst
 import Clash.Core.Term
-  ( CoreContext(..), Pat(..), PrimInfo(..), Term(..), collectArgs
+  ( CoreContext(..), Pat(..), PrimInfo(..), Term(..), WorkInfo(..), collectArgs
   , collectArgsTicks, mkApps , mkTicks, stripTicks)
 import Clash.Core.TermInfo (isLocalVar, isPolyFun, termSize, termType)
 import Clash.Core.Type
   (TypeView(..), isClassTy, isPolyFunCoreTy, tyView)
-import Clash.Core.Util (isSignalType)
+import Clash.Core.Util (isSignalType, primUCo)
 import Clash.Core.Var (Id, Var(..), isGlobalId, isLocalId)
 import Clash.Core.VarEnv
   ( InScopeSet, VarEnv, VarSet, elemUniqInScopeSet, elemVarEnv, elemVarSet
@@ -379,6 +382,54 @@ inlineCleanup (TransformContext is0 _) (Letrec binds body) = do
 inlineCleanup _ e = return e
 {-# SCC inlineCleanup #-}
 
+{- [Note] relation `collapseRHSNoops` and `inlineCleanup`
+The `collapseRHSNoops` transformation replaces functions/primitives that are the identity
+in HDL, but not in Haskell, by `unsafeCoerce`.
+`inlineCleanup` subsequently inlines these `unsafeCoerce` calls.
+The end result of all of this is that we get no/fewer assignments in HDL where the RHS is
+simply a variable reference. See issue #779 -}
+
+-- | Takes a binding and collapses its term if it is a noop
+collapseRHSNoops :: HasCallStack => NormRewrite
+collapseRHSNoops _ (Letrec binds body) = do
+  binds1 <- mapM runCollapseNoop binds
+  return $ Letrec binds1 body
+  where
+    runCollapseNoop orig =
+      runMaybeT (collapseNoop orig) >>= Maybe.maybe (return orig) changed
+
+    collapseNoop (iD,term) = do
+      (Prim info,args) <- return $ collectArgs term
+      identity         <- getIdentity info $ lefts args
+      collapsed        <- collapseToIdentity iD identity
+      return (iD,collapsed)
+
+    collapseToIdentity iD identity = do
+      tcm <- Lens.view tcCache
+      let aTy = termType tcm identity
+          bTy = varType iD
+      return $ primUCo `TyApp` aTy `TyApp` bTy `App` identity
+
+    getIdentity primInfo termArgs = do
+      WorkIdentity idIdx noopIdxs <- return $ primWorkInfo primInfo
+      mapM_ (getTermArg termArgs >=> isNoop >=> Monad.guard) noopIdxs
+      getTermArg termArgs idIdx
+
+    getTermArg args i = do
+      Monad.guard $ i <= length args - 1
+      return $ args !! i
+
+    isNoop (Var i) = do
+      binding     <- MaybeT $ lookupVarEnv i <$> Lens.use bindings
+      isRecursive <- lift $ isRecursiveBndr $ bindingId binding
+      Monad.guard $ not isRecursive
+      isNoop $ bindingTerm binding
+    isNoop (Prim PrimInfo{primWorkInfo=WorkIdentity _ []}) = return True
+    isNoop _ = return False
+
+collapseRHSNoops _ e = return e
+{-# SCC collapseRHSNoops #-}
+
 -- | Inline a function with functional arguments
 inlineHO :: HasCallStack => NormRewrite
 inlineHO _ e@(App _ _)

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

@@ -49,6 +49,7 @@ import qualified Data.Text                    as S
 import           Data.Text.Lazy               (Text)
 import           GHC.Generics                 (Generic)
 import           GHC.Stack                    (HasCallStack)
+import           Text.Read                    (readMaybe)
 
 -- | An unresolved primitive still contains pointers to files.
 type UnresolvedPrimitive = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe TemplateSource) (Maybe S.Text) (Maybe TemplateSource)
@@ -295,8 +296,14 @@ instance FromJSON UnresolvedPrimitive where
       parseWorkInfo (String "Never")    = pure (Just WorkNever)
       parseWorkInfo (String "Variable") = pure (Just WorkVariable)
       parseWorkInfo (String "Always")   = pure (Just WorkAlways)
+      parseWorkInfo (parseWorkIdentity -> wi@Just{}) = pure wi
       parseWorkInfo c = fail ("[6] unexpected workInfo: " ++ show c)
 
+      parseWorkIdentity arg = do
+        String str   <- return arg
+        [iStr,xsStr] <- words . S.unpack <$> S.stripPrefix "Identity" str
+        WorkIdentity <$> readMaybe iStr <*> readMaybe xsStr
+
       parseBBFN' = either fail return . parseBBFN
 
       defTemplateFunction = BlackBoxFunctionName ["Template"] "template"

clash-lib/src/Clash/Rewrite/WorkFree.hs

@@ -104,6 +104,7 @@ isWorkFree cache bndrs = go True
           -- regardless of their values.
           WorkConstant -> pure True
           WorkNever -> allM goArg args
+          WorkIdentity _ _ -> allM goArg args
           WorkVariable -> pure (all isConstantArg args)
           WorkAlways -> pure False
 

tests/Main.hs

@@ -530,6 +530,7 @@ runClashTest = defaultMain $ clashTestRoot
         , runTest "T1742" def{hdlSim=False, buildTargets=BuildSpecific ["shell"]}
         , runTest "T1756" def{hdlSim=False}
         , outputTest "T431" def{hdlTargets=[VHDL]}
+        , clashLibTest "T779" def{hdlTargets=[Verilog]}
         ] <>
         if compiledWith == Cabal then
           -- This tests fails without environment files present, which are only

tests/shouldwork/Issues/T779.hs

@@ -0,0 +1,33 @@
+-- Test that noops are collapsed to their argument as specified by `WorkIdentity`
+
+module T779 where
+
+import Clash.Netlist.Types (Component(..),Declaration(..))
+import qualified Data.Text as T
+import Test.Tasty.Clash
+import Test.Tasty.Clash.NetlistTest
+
+import Clash.Prelude
+
+topEntity :: Vec 4 Bit -> BitVector 4 -> (Vec 4 Bit,BitVector 4)
+topEntity a b = (vecRoundTrip a,bvRoundTrip b)
+  where vecRoundTrip = bv2v . v2bv
+        bvRoundTrip  = v2bv . bv2v
+
+testPath :: FilePath
+testPath = "tests/shouldwork/Issues/T779.hs"
+
+assertAllCollpased :: Component -> IO ()
+assertAllCollpased = mapM_ checkCollapse . declarations
+  where
+    checkCollapse (BlackBoxD primName _ _ _ _ _)
+      | primName `elem` toCollapse = error $ "Found uncollapsed noops: " <> show primName
+    checkCollapse _                = return ()
+
+    toCollapse = T.pack <$> ["Clash.Sized.Vector.map"
+                            ,"Clash.Sized.Internal.BitVector.pack#"
+                            ,"Clash.Sized.Internal.BitVector.unpack#"]
+mainVerilog :: IO ()
+mainVerilog = do
+  netlist <- runToNetlistStage SVerilog id testPath
+  mapM_ (assertAllCollpased . snd) netlist