diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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, diff --git a/prims/common/Clash_Class_BitPack.primitives.yaml b/prims/common/Clash_Class_BitPack.primitives.yaml --- a/prims/common/Clash_Class_BitPack.primitives.yaml +++ b/prims/common/Clash_Class_BitPack.primitives.yaml @@ -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 diff --git a/prims/common/Clash_GHC_GHC2Core.primitives.yaml b/prims/common/Clash_GHC_GHC2Core.primitives.yaml --- a/prims/common/Clash_GHC_GHC2Core.primitives.yaml +++ b/prims/common/Clash_GHC_GHC2Core.primitives.yaml @@ -1,8 +1,3 @@ -- BlackBox: - name: EmptyCase - kind: Expression - template: ~ERRORO - workInfo: Constant - Primitive: name: _CO_ primType: Constructor diff --git a/prims/common/Clash_Normalize_Primitives.primitives.yaml b/prims/common/Clash_Normalize_Primitives.primitives.yaml --- a/prims/common/Clash_Normalize_Primitives.primitives.yaml +++ b/prims/common/Clash_Normalize_Primitives.primitives.yaml @@ -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]' diff --git a/prims/common/GHC_Err.primitives.yaml b/prims/common/GHC_Err.primitives.yaml --- a/prims/common/GHC_Err.primitives.yaml +++ b/prims/common/GHC_Err.primitives.yaml @@ -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 diff --git a/prims/common/GHC_TypeNats.primitives.yaml b/prims/common/GHC_TypeNats.primitives.yaml --- a/prims/common/GHC_TypeNats.primitives.yaml +++ b/prims/common/GHC_TypeNats.primitives.yaml @@ -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 diff --git a/prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml b/prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml --- a/prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml +++ b/prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml @@ -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# diff --git a/src/Clash/Backend.hs b/src/Clash/Backend.hs --- a/src/Clash/Backend.hs +++ b/src/Clash/Backend.hs @@ -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 diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs --- a/src/Clash/Backend/SystemVerilog.hs +++ b/src/Clash/Backend/SystemVerilog.hs @@ -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 diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs --- a/src/Clash/Backend/VHDL.hs +++ b/src/Clash/Backend/VHDL.hs @@ -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 diff --git a/src/Clash/Backend/Verilog.hs b/src/Clash/Backend/Verilog.hs --- a/src/Clash/Backend/Verilog.hs +++ b/src/Clash/Backend/Verilog.hs @@ -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 diff --git a/src/Clash/Core/PartialEval/NormalForm.hs b/src/Clash/Core/PartialEval/NormalForm.hs --- a/src/Clash/Core/PartialEval/NormalForm.hs +++ b/src/Clash/Core/PartialEval/NormalForm.hs @@ -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. @@ -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 diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -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. @@ -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 diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -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. diff --git a/src/Clash/Driver/Types.hs b/src/Clash/Driver/Types.hs --- a/src/Clash/Driver/Types.hs +++ b/src/Clash/Driver/Types.hs @@ -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) diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -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 diff --git a/src/Clash/Netlist/Types.hs b/src/Clash/Netlist/Types.hs --- a/src/Clash/Netlist/Types.hs +++ b/src/Clash/Netlist/Types.hs @@ -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. @@ -740,9 +740,11 @@ -> TemplateFunction instance Show BlackBox where - show (BBTemplate t) = "BBTemplate " <> show t - show (BBFunction nm hsh _) = - "" + showsPrec d (BBTemplate t) = + showParen (d > 10) $ ("BBTemplate " ++) . showsPrec 11 t + showsPrec _ (BBFunction nm hsh _) = + ("" ++) instance NFData TemplateFunction where rnf (TemplateFunction is f _) = rnf is `seq` f `seq` () diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -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 diff --git a/src/Clash/Normalize/Primitives.hs b/src/Clash/Normalize/Primitives.hs --- a/src/Clash/Normalize/Primitives.hs +++ b/src/Clash/Normalize/Primitives.hs @@ -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. @@ -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 diff --git a/src/Clash/Normalize/Transformations/Case.hs b/src/Clash/Normalize/Transformations/Case.hs --- a/src/Clash/Normalize/Transformations/Case.hs +++ b/src/Clash/Normalize/Transformations/Case.hs @@ -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. @@ -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 diff --git a/src/Clash/Normalize/Transformations/Inline.hs b/src/Clash/Normalize/Transformations/Inline.hs --- a/src/Clash/Normalize/Transformations/Inline.hs +++ b/src/Clash/Normalize/Transformations/Inline.hs @@ -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. @@ -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 #-} diff --git a/src/Clash/Primitives/DSL.hs b/src/Clash/Primitives/DSL.hs --- a/src/Clash/Primitives/DSL.hs +++ b/src/Clash/Primitives/DSL.hs @@ -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 diff --git a/src/Clash/Primitives/Intel/ClockGen.hs b/src/Clash/Primitives/Intel/ClockGen.hs --- a/src/Clash/Primitives/Intel/ClockGen.hs +++ b/src/Clash/Primitives/Intel/ClockGen.hs @@ -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. @@ -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)) diff --git a/src/Clash/Primitives/Sized/Signed.hs b/src/Clash/Primitives/Sized/Signed.hs --- a/src/Clash/Primitives/Sized/Signed.hs +++ b/src/Clash/Primitives/Sized/Signed.hs @@ -1,5 +1,5 @@ {-| - Copyright : (C) 2021 QBayLogic + Copyright : (C) 2021-2022, QBayLogic License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -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))])