clash-lib 1.6.2 → 1.6.3

raw patch · 25 files changed

+190/−67 lines, 25 filesdep ~clash-preludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: clash-prelude

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−1
• clash-lib.cabal +2/−2
• prims/common/Clash_Class_BitPack.primitives.yaml +6/−0
• prims/common/Clash_GHC_GHC2Core.primitives.yaml +0/−5
• prims/common/Clash_Normalize_Primitives.primitives.yaml +6/−0
• prims/common/GHC_Err.primitives.yaml +3/−5
• prims/common/GHC_TypeNats.primitives.yaml +5/−0
• prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml +1/−1
• src/Clash/Backend.hs +4/−0
• src/Clash/Backend/SystemVerilog.hs +4/−0
• src/Clash/Backend/VHDL.hs +4/−0
• src/Clash/Backend/Verilog.hs +4/−0
• src/Clash/Core/PartialEval/NormalForm.hs +11/−2
• src/Clash/Core/Util.hs +8/−3
• src/Clash/Driver.hs +2/−1
• src/Clash/Driver/Types.hs +3/−2
• src/Clash/Netlist/BlackBox/Util.hs +20/−5
• src/Clash/Netlist/Types.hs +6/−4
• src/Clash/Netlist/Util.hs +5/−5
• src/Clash/Normalize/Primitives.hs +15/−1
• src/Clash/Normalize/Transformations/Case.hs +18/−9
• src/Clash/Normalize/Transformations/Inline.hs +25/−1
• src/Clash/Primitives/DSL.hs +3/−3
• src/Clash/Primitives/Intel/ClockGen.hs +7/−7
• src/Clash/Primitives/Sized/Signed.hs +13/−10

@@ -1,6 +1,20 @@ # Changelog for the Clash project+## 1.6.3 *Apr 7th 2022*+Fixed:+  * Handle `~ISUNDEFINED` hole in black boxes for `BitVector` and for product types. This means that with `-fclash-aggressive-x-optimization-blackboxes`, resets are now omitted for _undefined_ reset values of such types as well. [#2117](https://github.com/clash-lang/clash-compiler/issues/2117)+  * The `alteraPll` primitive was unusable since commit `d325557750` (release v1.4.0), it now works again. [#2136](https://github.com/clash-lang/clash-compiler/pull/2136)+  * Simulation/Synthesis mismatch for X-exception to undefined bitvector conversion [#2154](https://github.com/clash-lang/clash-compiler/issues/2154)+  * The VHDL blackbox for `Signed.fromInteger` can now handle any `Netlist Expr` as input [#2149](https://github.com/clash-lang/clash-compiler/issues/2149)+  * Clash no longer escapes extended identifiers when rendering SDC files. [#2142](https://github.com/clash-lang/clash-compiler/pull/2142)+  * The types defined in `clash-prelude-hedgehog` now come with `Show` instances [#2133](https://github.com/clash-lang/clash-compiler/issues/2133)+  * Extreme values are now generated from the input range instead of the type's bounds [#2138](https://github.com/clash-lang/clash-compiler/issues/2138) -## 1.6.2 *Fed 25th 2022*+Internal change:+  * Clash now always generates non-extended identifiers for port names, so that generated names play nicer with different vendor tools. [#2142](https://github.com/clash-lang/clash-compiler/pull/2142)+  * Top entity name available in netlist context. Top entity name used in generated name for include files. [#2146](https://github.com/clash-lang/clash-compiler/pull/2146)+++## 1.6.2 *Feb 25th 2022* Fixed:   * Clash now compiles for users of Clang - i.e., all macOS users.   * The `trueDualPortBlockRam` model did not accurately simulate concurrent active ports, thus causing a Haskell/HDL simulation mismatch for `asyncFIFOSynchronizer`.

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-lib-Version:              1.6.2+Version:              1.6.3 Synopsis:             Clash: a functional hardware description language - As a library Description:   Clash is a functional hardware description language that borrows both its@@ -136,7 +136,7 @@                       base16-bytestring       >= 0.1.1    && < 1.1,                       binary                  >= 0.8.5    && < 0.11,                       bytestring              >= 0.10.0.2 && < 0.12,-                      clash-prelude           == 1.6.2,+                      clash-prelude           == 1.6.3,                       concurrent-supply       >= 0.1.7    && < 0.2,                       containers              >= 0.5.0.0  && < 0.7,                       cryptohash-sha256       >= 0.11     && < 0.12,

@@ -26,3 +26,9 @@       64 -> Double'     template: ~ARG[0]     workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.xToBV+    kind: Expression+    type: 'xToBV :: KnownNat n => BitVector n -> BitVector n'+    template: ~ARG[1]+    workInfo: Never

@@ -1,8 +1,3 @@-- BlackBox:-    name: EmptyCase-    kind: Expression-    template: ~ERRORO-    workInfo: Constant - Primitive:     name: _CO_     primType: Constructor

@@ -12,6 +12,12 @@     template: ~ERRORO     workInfo: Constant - BlackBox:+    name: Clash.Normalize.Primitives.undefinedX+    kind: Expression+    type: 'undefinedX :: forall a . a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:     name: c$multiPrimSelect     kind: Expression     template: '!__SHOULD NOT BE RENDERED__! ~ARG[0]~ARG[1]'

@@ -1,20 +1,18 @@ - BlackBox:     name: GHC.Err.error     kind: Expression-    type: 'error :: [Char]-      -> a'+    type: 'error :: forall r a . HasCallStack => [Char] -> a'     template: ~ERRORO     workInfo: Constant - BlackBox:     name: GHC.Err.errorWithoutStackTrace     kind: Expression-    type: 'errorWithoutStackTrace-      :: [Char] -> a'+    type: 'errorWithoutStackTrace :: forall r a . [Char] -> a'     template: ~ERRORO     workInfo: Constant - BlackBox:     name: GHC.Err.undefined     kind: Expression-    type: 'undefined :: a'+    type: 'undefined :: forall r a . HasCallStack => a'     template: ~ERRORO     workInfo: Constant

@@ -5,3 +5,8 @@       n proxy. KnownNat n => proxy n -> Natural'     template: ~ARG[0]     workInfo: Never+- Primitive:+    name: GHC.TypeNats.someNatVal+    primType: Functions+    type: 'someNatVal :: Natural -> SomeNat'+    workInfo: Never

@@ -97,7 +97,7 @@     kind: Expression     type: 'fromInteger# ::       KnownNat n => Integer -> Signed (n :: Nat)'-    templateFunction: Clash.Primitives.Sized.Signed.fromIntegerTF+    templateFunction: Clash.Primitives.Sized.Signed.fromIntegerTFvhdl     workInfo: Never - BlackBox:     name: Clash.Sized.Internal.Signed.toEnum#

@@ -140,6 +140,10 @@   hdlSyn           :: State state HdlSyn   -- | setModName   setModName       :: ModName -> state -> state+  -- | Set the name of the current top entity+  setTopName       :: Identifier -> state -> state+  -- | Get the name of the current top entity+  getTopName       :: State state Identifier   -- | setSrcSpan   setSrcSpan       :: SrcSpan -> State state ()   -- | getSrcSpan

@@ -73,6 +73,7 @@     , _nameCache :: HashMap HWType Identifier -- ^ Cache for previously generated product type names     , _genDepth  :: Int -- ^ Depth of current generative block     , _modNm     :: ModName+    , _topNm     :: Identifier     , _idSeen    :: IdentifierSet     , _oports    :: [Identifier]     , _srcSpan   :: SrcSpan@@ -105,6 +106,7 @@     , _nameCache=HashMap.empty     , _genDepth=0     , _modNm=""+    , _topNm=Id.unsafeMake ""     , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) SystemVerilog     , _oports=[]     , _srcSpan=noSrcSpan@@ -163,6 +165,8 @@   fromBV hty id_  = simpleFromSLV hty (Text.toStrict id_)   hdlSyn          = use hdlsyn   setModName nm s = s {_modNm = nm}+  setTopName nm s = s {_topNm = nm}+  getTopName      = use topNm   setSrcSpan      = (srcSpan .=)   getSrcSpan      = use srcSpan   blockDecl _ ds  = do

@@ -90,6 +90,7 @@   -- ^ Cache for type names. Bool indicates whether this name includes length   -- information in its first "part". See `tyName'` for more information.   , _modNm     :: ModName+  , _topNm     :: Identifier   , _srcSpan   :: SrcSpan   , _libraries :: [T.Text]   , _packages  :: [T.Text]@@ -126,6 +127,7 @@     { _tyCache=mempty     , _nameCache=mempty     , _modNm=""+    , _topNm=Id.unsafeMake ""     , _srcSpan=noSrcSpan     , _libraries=[]     , _packages=[]@@ -233,6 +235,8 @@       qualTyName t <> "'" <> parens (pretty nm <> "_types.fromSLV" <> parens (pretty id_))   hdlSyn          = use hdlsyn   setModName nm s = s {_modNm = nm}+  setTopName nm s = s {_topNm = nm}+  getTopName      = use topNm   setSrcSpan      = (srcSpan .=)   getSrcSpan      = use srcSpan   blockDecl nm ds = do

@@ -84,6 +84,7 @@   VerilogState     { _genDepth  :: Int -- ^ Depth of current generative block     , _idSeen    :: IdentifierSet+    , _topNm     :: Identifier     , _srcSpan   :: SrcSpan     , _includes  :: [(String,Doc)]     , _imports   :: HashSet Text.Text@@ -111,6 +112,7 @@   initBackend opts = VerilogState     { _genDepth=0     , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) Verilog+    , _topNm=Id.unsafeMake ""     , _srcSpan=noSrcSpan     , _includes=[]     , _imports=HashSet.empty@@ -163,6 +165,8 @@     _ -> string e   hdlSyn          = use hdlsyn   setModName _    = id+  setTopName nm s = s {_topNm = nm}+  getTopName      = use topNm   setSrcSpan      = (srcSpan .=)   getSrcSpan      = use srcSpan   blockDecl _ ds  = do

@@ -1,5 +1,6 @@ {-|-Copyright   : (C) 2020-2021, QBayLogic B.V.+Copyright   : (C) 2020-2021, QBayLogic B.V.,+                  2022     , Google Inc. License     : BSD2 (see the file LICENSE) Maintainer  : QBayLogic B.V. <devops@qbaylogic.com> @@ -24,6 +25,7 @@   , stripValue   , collectValueTicks   , isUndefined+  , isUndefinedX   , Normal(..)   , LocalEnv(..)   , GlobalEnv(..)@@ -40,7 +42,7 @@ import Clash.Core.Term (Bind, Term(..), PrimInfo(primName), TickInfo, Pat) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type, TyVar)-import Clash.Core.Util (undefinedPrims)+import Clash.Core.Util (undefinedPrims, undefinedXPrims) import Clash.Core.Var (Id) import Clash.Core.VarEnv (VarEnv, InScopeSet) import Clash.Driver.Types (Binding(..))@@ -124,6 +126,13 @@ isUndefined = \case   VNeutral (NePrim pr _) ->     primName pr `elem` undefinedPrims++  _ -> False++isUndefinedX :: Value -> Bool+isUndefinedX = \case+  VNeutral (NePrim pr _) ->+    primName pr `elem` undefinedXPrims    _ -> False 

@@ -1,6 +1,7 @@ {-|   Copyright   :  (C) 2012-2016, University of Twente,-                     2021     , QBayLogic B.V.+                     2021     , QBayLogic B.V.,+                     2022     , Google Inc.   License     :  BSD2 (see the file LICENSE)   Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> @@ -466,10 +467,8 @@ undefinedPrims :: [T.Text] undefinedPrims =   [ "Clash.Normalize.Primitives.undefined"-  , "Clash.XException.errorX"   , "Control.Exception.Base.absentError"   , "Control.Exception.Base.patError"-  , "EmptyCase"   , "GHC.Err.error"   , "GHC.Err.errorWithoutStackTrace"   , "GHC.Err.undefined"@@ -477,6 +476,12 @@   , "GHC.Real.overflowError"   , "GHC.Real.ratioZeroDenominatorError"   , "GHC.Real.underflowError"+  ]++undefinedXPrims :: [T.Text]+undefinedXPrims =+  [ "Clash.Normalize.Primitives.undefinedX"+  , "Clash.XException.errorX"   ]  substArgTys

@@ -383,6 +383,7 @@       modNameT  = Data.Text.pack modNameS       hdlState' = setDomainConfigurations domainConfs                 $ setModName modNameT+                $ setTopName topNm                 $ fromMaybe (initBackend @backend opts) hdlState       hdlDir    = fromMaybe (Clash.Backend.name hdlState') (opt_hdlDir opts) </> topEntityS       manPath   = hdlDir </> manifestFilename@@ -595,7 +596,7 @@     , ('P.alteraPllQsysTF, P.alteraPllQsysTF)     , ('P.alteraPllTF, P.alteraPllTF)     , ('P.altpllTF, P.altpllTF)-    , ('P.fromIntegerTF, P.fromIntegerTF)+    , ('P.fromIntegerTFvhdl, P.fromIntegerTFvhdl)     ]  -- | Compiles blackbox functions and parses blackbox templates.

@@ -31,6 +31,7 @@ import           Data.Set                       (Set) import qualified Data.Set                       as Set import           Data.Text                      (Text)+import qualified Data.Text as Text              (dropAround)  #if MIN_VERSION_prettyprinter(1,7,0) import           Prettyprinter@@ -337,7 +338,7 @@   , opt_color :: OverridingBool   -- ^ Show colors in debug output   ---  -- Command line flag: -fclash-no-prim-warn+  -- Command line flag: -fdiagnostics-color   , opt_intWidth :: Int   -- ^ Set the bit width for the Int/Word/Integer types. The only allowed values   -- are 32 or 64.@@ -548,7 +549,7 @@   go (i, dom) =         -- VDomainConfiguration stores period in ps, SDC expects it in ns.     let p        = MkFixed (toInteger $ vPeriod dom) :: Fixed E3-        name     = braces (pretty i)+        name     = braces (pretty (Text.dropAround (== '\\') i))         period   = viaShow p         waveform = braces ("0.000" <+> viaShow (p / 2))         targets  = brackets ("get_ports" <+> name)

@@ -302,9 +302,13 @@                                   return (const t'))                                inc       iw <- iwWidth+      topNm <- getTopName       let incHash = hash (incForHash 0)           nm'     = Text.concat-                      [ Text.fromStrict nm+                      [ Text.fromStrict (Id.toText topNm)+                      , "_"+                      , Text.fromStrict nm+                      , "_"                       , Text.pack (printf ("%0" ++ show (iw `div` 4) ++ "X") incHash)                       ]       pure nm'@@ -474,10 +478,8 @@                       _            -> 0        (IsUndefined n) ->-        let (e, _, _) = bbInputs b !! n in-        case (xOpt, e) of-          (True, BlackBoxE _ _ _ _ (N.BBTemplate [Err _]) _ _) -> 1-          _ -> 0+        let (e, _, _) = bbInputs b !! n+        in if xOpt && checkUndefined e then 1 else 0        (IsActiveEnable n) ->         let (e, ty, _) = bbInputs b !! n in@@ -1147,3 +1149,16 @@   -> r onBlackBox f _ (N.BBTemplate t) = f t onBlackBox _ g (N.BBFunction n h t) = g n h t++-- | Is the value of the 'Expr' fully undefined?+checkUndefined :: Expr -> Bool+checkUndefined = \case+  BlackBoxE _ _ _ _ (N.BBTemplate [Err _]) _ _ -> True+  BlackBoxE "Clash.Sized.Internal.BitVector.fromInteger#" [] [] [] _ bbCtx _+    | [sz, mask, _val] <- bbInputs bbCtx+    , (Literal _ (NumLit sz0), _, True) <- sz+    , (Literal _ (NumLit mask0), _, True) <- mask+    , mask0 == 2^sz0 - 1+    -> True+  DataCon (Product _ _ _) _ es -> and (map checkUndefined es)+  _ -> False

@@ -2,7 +2,7 @@   Copyright  :  (C) 2012-2016, University of Twente,                     2017     , Myrtle Software Ltd,                     2017-2018, Google Inc.-                    2020-2021, QBayLogic B.V.+                    2020-2022, QBayLogic B.V.   License    :  BSD2 (see the file LICENSE)   Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> @@ -740,9 +740,11 @@     -> TemplateFunction  instance Show BlackBox where-  show (BBTemplate t)  = "BBTemplate " <> show t-  show (BBFunction nm hsh _) =-    "<TemplateFunction(nm=" ++ show nm ++ ", hash=" ++ show hsh ++ ")>"+  showsPrec d (BBTemplate t) =+    showParen (d > 10) $ ("BBTemplate " ++) . showsPrec 11 t+  showsPrec _ (BBFunction nm hsh _) =+    ("<TemplateFunction(nm=" ++) . shows nm . (", hash=" ++) . shows hsh .+    (")>" ++)  instance NFData TemplateFunction where   rnf (TemplateFunction is f _) = rnf is `seq` f `seq` ()

@@ -1129,7 +1129,7 @@   return ([(i0, hwty1)], decls, expr, i1)  mkTopInput epp@(ExpandedPortProduct p hwty ps) = do-  pN <- Id.make p+  pN <- Id.makeBasic p   let netdecl = NetDecl Nothing pN hwty   case hwty of     Vector sz eHwty -> do@@ -1272,7 +1272,7 @@     return ([(i0, hwty1)], [Assignment i0 bvExpr, NetDecl Nothing i1 hwty0], i1)  mkTopOutput epp@(ExpandedPortProduct p hwty ps) = do-  pN <- Id.make p+  pN <- Id.makeBasic p   let netdecl = NetDecl Nothing pN hwty   case hwty of     Vector {} -> do@@ -1411,7 +1411,7 @@           , pN' )  mkTopInstInput epp@(ExpandedPortProduct pNameHint hwty0 ps) = do-  pName <- Id.make pNameHint+  pName <- Id.makeBasic pNameHint    let     pDecl = NetDecl Nothing pName hwty0@@ -1508,7 +1508,7 @@           , assignName1 )  mkTopInstOutput epp@(ExpandedPortProduct productNameHint hwty ps) = do-  pName <- Id.make productNameHint+  pName <- Id.makeBasic productNameHint   let pDecl = NetDecl Nothing pName hwty       (attrs, hwty') = stripAttributes hwty   case hwty' of@@ -1755,7 +1755,7 @@         is not a product!       |])     Right eTop ->-      evalState (traverse (either Id.addRaw Id.make) eTop) (Id.clearSet is)+      evalState (traverse (either Id.addRaw Id.makeBasic) eTop) (Id.clearSet is)  -- | Take a top entity and /expand/ its port names. I.e., make sure that every -- port that should be generated in the HDL is part of the data structure. It

@@ -1,5 +1,6 @@ {-|-Copyright   : (C) 2021, QBayLogic B.V.+Copyright   : (C) 2021, QBayLogic B.V.,+                  2022, Google Inc. License     : BSD2 (see the file LICENSE) Maintainer  : QBayLogic B.V. <devops@qbaylogic.com> @@ -11,6 +12,7 @@ module Clash.Normalize.Primitives   ( removedArg   , undefined+  , undefinedX   ) where  import Prelude hiding (undefined)@@ -41,6 +43,18 @@ undefined :: PrimInfo undefined = PrimInfo   { primName = Text.showt 'undefined+  , primType = undefinedTy+  , primWorkInfo = WorkNever+  , primMultiResult = SingleResult+  , primUnfolding = NoUnfolding+  }++-- | The undefinedX primitive represents an X-exception throwing value that was+-- identified during normalization.+--+undefinedX :: PrimInfo+undefinedX = PrimInfo+  { primName = Text.showt 'undefinedX   , primType = undefinedTy   , primWorkInfo = WorkNever   , primMultiResult = SingleResult

@@ -1,7 +1,7 @@ {-|   Copyright  :  (C) 2012-2016, University of Twente,                     2016-2017, Myrtle Software Ltd,-                    2017-2018, Google Inc.,+                    2017-2022, Google Inc.,                     2021-2022, QBayLogic B.V.   License    :  BSD2 (see the file LICENSE)   Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>@@ -70,7 +70,7 @@ import Clash.Driver.Types (DebugOpts(dbg_invariants)) import Clash.Netlist.Types (FilteredHWType(..), HWType(..)) import Clash.Netlist.Util (coreTypeToHWType, representableType)-import qualified Clash.Normalize.Primitives as NP (undefined)+import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators ((>-!)) import Clash.Rewrite.Types@@ -263,6 +263,13 @@       (Literal l,_,_) -> caseCon ctx1 (Case (Literal l) ty alts)       -- WHNF of subject is a data-constructor, try `caseCon` with that       (Data _,_,_) -> caseCon ctx1 (Case subj1 ty alts)+      -- WHNF of subject is _|_, in the form of `error`: that means that the+      -- entire case-expression is evaluates to _|_+      (Prim pInfo,repTy:_:callStack:msg:_,ticks)+        | primName pInfo == "GHC.Err.error" ->+        let e1 = mkApps (mkTicks (Prim pInfo) ticks)+                        [repTy,Right ty,callStack,msg]+         in changed e1       -- WHNF of subject is _|_, in the form of `absentError`: that means that       -- the entire case-expression is evaluates to _|_       (Prim pInfo,_:msgOrCallStack:_,ticks)@@ -270,11 +277,12 @@         let e1 = mkApps (mkTicks (Prim pInfo) ticks)                         [Right ty,msgOrCallStack]         in  changed e1-      -- WHNF of subject is _|_, in the form of `absentError`, `patError`,-      -- or `undefined`: that means the entire case-expression is _|_+      -- WHNF of subject is _|_, in the form of  `patError`, `undefined`, or+      -- `errorWithoutStackTrace`: that means the entire case-expression is _|_       (Prim pInfo,repTy:_:msgOrCallStack:_,ticks)         | primName pInfo `elem` ["Control.Exception.Base.patError"-                                ,"GHC.Err.undefined"] ->+                                ,"GHC.Err.undefined"+                                ,"GHC.Err.errorWithoutStackTrace"] ->         let e1 = mkApps (mkTicks (Prim pInfo) ticks)                         [repTy,Right ty,msgOrCallStack]         in  changed e1@@ -282,13 +290,14 @@       -- means the entire case-expression is _|_       (Prim pInfo,[_],ticks)         | primName pInfo `elem` [ Text.showt 'NP.undefined-                                , "Clash.GHC.Evaluator.undefined"-                                , "EmptyCase"] ->+                                , Text.showt 'NP.undefinedX ] ->         let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty]         in changed e1-      (Prim pInfo,_:callStack:msg:_,_)+      -- WHNF of subject is _|_, in the form of `errorX`: that means that+      -- the entire case-expression is evaluates to _|_+      (Prim pInfo,_:callStack:msg:_,ticks)         | primName pInfo == "Clash.XException.errorX"-        -> let e1 = mkApps (Prim pInfo) [Right ty,callStack,msg]+        -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,callStack,msg]             in changed e1       -- WHNF of subject is non of the above, so either a variable reference,       -- or a primitive for which the evaluator doesn't have any evaluation

@@ -1,7 +1,7 @@ {-|   Copyright  :  (C) 2012-2016, University of Twente,                     2016-2017, Myrtle Software Ltd,-                    2017-2018, Google Inc.,+                    2017-2022, Google Inc.,                     2021-2022, QBayLogic B.V.   License    :  BSD2 (see the file LICENSE)   Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>@@ -425,7 +425,31 @@       Monad.guard $ not isRecursive       isNoop $ bindingTerm binding     isNoop (Prim PrimInfo{primWorkInfo=WorkIdentity _ []}) = return True+    isNoop (Lam x e) = isNoopApp x (collectArgs e)     isNoop _ = return False++    -- Check whether we have a term of the form:+    --+    -- primX a (primY b (primZ c (... x ...))))+    --+    -- Where primX, primY and primZ are either:+    --+    --  1. xToBV, or+    --  2. Primitives that are the identity on their argument+    --+    -- And that the variable 'x' is used by the last primitive in the chain.+    isNoopApp x (Var y,[]) = return (x == y)+    isNoopApp x (Prim PrimInfo{primWorkInfo=WorkIdentity i []},args) = do+      arg <- getTermArg (lefts args) i+      isNoopApp x (collectArgs arg)+    isNoopApp x (Prim PrimInfo{primName="Clash.Class.BitPack.Internal.xToBV"},args) = do+      -- We don't make 'xToBV' something of 'WorkIdentity 1 []' because we don't+      -- want 'getIdentity' to replace "naked" occurances of 'xToBV' by+      -- 'unsafeCoerce#'. We don't want that since 'xToBV' has a special evaluator+      -- rule that can translate XExceptions to 'undefined# :: BitVector n'.+      arg@(App {}) <- getTermArg (lefts args) 1+      isNoopApp x (collectArgs arg)+    isNoopApp _ _ = return False  collapseRHSNoops _ e = return e {-# SCC collapseRHSNoops #-}

@@ -25,7 +25,7 @@     BlackBoxHaskellOpts(..)   , blackBoxHaskell -  -- * declarations+  -- * Declarations   , BlockState (..)   , TExpr   , declaration@@ -139,10 +139,10 @@ -- | Create a blackBoxHaskell primitive. To be used as part of an annotation: -- -- @--- {-# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{_ignoredArguments=[2,3]}) #-}+-- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{_ignoredArguments=[1,2]}) \#-} -- @ ----- [2,3] would mean this blackbox __ignores__ its second and third argument.+-- @[1,2]@ would mean this blackbox __ignores__ its second and third argument. blackBoxHaskell   :: Name   -- ^ blackbox name

@@ -1,6 +1,6 @@ {-|-  Copyright   :  (C) 2018, Google Inc.,-                     2021, QBayLogic B.V.+  Copyright   :  (C) 2018     , Google Inc.,+                     2021-2022, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)   Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> @@ -80,7 +80,7 @@  alteraPll <- Id.makeBasic "altera_pll_block"  alteraPll_inst <- Id.makeBasic instname0 - clocks <- Id.nextN (length tys - 1) =<< Id.make "pllOut"+ clocks <- Id.nextN (length tys) =<< Id.make "pllOut"    -- TODO: unsafeMake is dubious here: I don't think we take names in   -- TODO: bbQsysIncName into account when generating fresh ids@@ -89,15 +89,15 @@  let outclkPorts = map (\n -> instPort ("outclk_" <> showt n)) [(0 :: Int)..length clocks-1]   getAp $ blockDecl alteraPll $ concat-  [[ NetDecl Nothing locked  rstTy+  [[ NetDecl Nothing locked Bit    , NetDecl' Nothing Reg pllLock (Right Bool) Nothing]   ,[ NetDecl Nothing clkNm ty | (clkNm,ty) <- zip clocks tys]   ,[ InstDecl Comp Nothing [] compName alteraPll_inst [] $ NamedPortMap $ concat       [ [ (instPort "refclk", In, clkTy, clk)         , (instPort "rst", In, rstTy, rst)]       , [ (p, Out, ty, Identifier k Nothing) | (k, ty, p) <- zip3 clocks tys outclkPorts ]-      , [(instPort "locked", Out, rstTy, Identifier locked Nothing)]]-   , CondAssignment pllLock Bool (Identifier locked Nothing) rstTy+      , [(instPort "locked", Out, Bit, Identifier locked Nothing)]]+   , CondAssignment pllLock Bool (Identifier locked Nothing) Bit       [(Just (BitLit H),Literal Nothing (BoolLit True))       ,(Nothing        ,Literal Nothing (BoolLit False))]    , Assignment result (DataCon resTy (DC (resTy,0)) $ concat@@ -136,7 +136,7 @@       , (instPort "areset", In, rstTy, rst)       , (instPort "c0", Out, clkOutTy, Identifier pllOut Nothing)       , (instPort "locked", Out, Bit, Identifier locked Nothing)]-  , CondAssignment pllLock Bool (Identifier locked Nothing) rstTy+  , CondAssignment pllLock Bool (Identifier locked Nothing) Bit       [(Just (BitLit H),Literal Nothing (BoolLit True))       ,(Nothing        ,Literal Nothing (BoolLit False))]   , Assignment result (DataCon resTy (DC (resTy,0))

@@ -1,5 +1,5 @@ {-|-  Copyright   :  (C) 2021 QBayLogic+  Copyright   :  (C) 2021-2022, QBayLogic   License     :  BSD2 (see the file LICENSE)   Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> @@ -7,7 +7,7 @@ -}  {-# LANGUAGE OverloadedStrings #-}-module Clash.Primitives.Sized.Signed (fromIntegerTF) where+module Clash.Primitives.Sized.Signed (fromIntegerTFvhdl) where  import Control.Monad.State (State) import Data.Monoid (Ap(getAp))@@ -18,8 +18,8 @@   (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),    TemplateFunction (..)) -fromIntegerTF :: TemplateFunction-fromIntegerTF = TemplateFunction used valid fromIntegerTFTemplate+fromIntegerTFvhdl :: TemplateFunction+fromIntegerTFvhdl = TemplateFunction used valid fromIntegerTFTemplateVhdl  where   used = [0,1]   valid bbCtx = case bbInputs bbCtx of@@ -28,16 +28,19 @@       _ -> False     _ -> False -fromIntegerTFTemplate+fromIntegerTFTemplateVhdl   :: Backend s   => BlackBoxContext   -> State s Doc-fromIntegerTFTemplate bbCtx = getAp $ do-  let [(Literal _ (NumLit sz),_,_), (i@(Identifier iV m), Signed szI, _)] = bbInputs bbCtx+fromIntegerTFTemplateVhdl bbCtx = getAp $ do+  let [(Literal _ (NumLit sz),_,_), (i, Signed szI, _)] = bbInputs bbCtx   case compare sz (toInteger szI) of-    LT -> let sl = Sliced (Signed szI,fromInteger sz-1,0)-              m1 = Just (maybe sl (`Nested` sl) m)-           in expr False (Identifier iV m1)+    LT -> case i of+           Identifier iV m ->+            let sl = Sliced (Signed szI,fromInteger sz-1,0)+                m1 = Just (maybe sl (`Nested` sl) m)+            in expr False (Identifier iV m1)+           _ -> "signed(std_logic_vector(resize(unsigned(std_logic_vector(" <> expr False i <> "))," <> expr False (Literal Nothing (NumLit sz)) <> ")))"     EQ -> expr False i     GT -> "resize" <> tupled (sequenceA [expr False i                                         ,expr False (Literal Nothing (NumLit sz))])