clash-lib 1.8.1 → 1.8.2
raw patch · 63 files changed
+1262/−763 lines, 63 filesdep +ghc-primdep −concurrent-supplydep −stringsearchdep ~clash-preludedep ~data-defaultdep ~extraPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: ghc-prim
Dependencies removed: concurrent-supply, stringsearch
Dependency ranges changed: clash-prelude, data-default, extra, ghc, template-haskell, text
API changes (from Hackage documentation)
- Clash.Driver: processHintError :: Monad m => String -> Text -> (t -> r) -> Either InterpreterError t -> m r
- Clash.Util: instance GHC.Base.Monad m => Clash.Util.MonadUnique (Control.Monad.Trans.State.Lazy.StateT GHC.Types.Int m)
+ Clash.Driver: HintError :: String -> HintError
+ Clash.Driver: instance GHC.Exception.Type.Exception Clash.Driver.HintError
+ Clash.Driver: instance GHC.Show.Show Clash.Driver.HintError
+ Clash.Driver: newtype HintError
+ Clash.Driver: processHintErrors :: (MonadThrow m, Monad m) => String -> Text -> Either (NonEmpty InterpreterError) t -> m t
+ Clash.Driver.Bool: Always :: OverridingBool
+ Clash.Driver.Bool: Auto :: OverridingBool
+ Clash.Driver.Bool: Never :: OverridingBool
+ Clash.Driver.Bool: data OverridingBool
+ Clash.Driver.Bool: fromGhcOverridingBool :: OverridingBool -> OverridingBool
+ Clash.Driver.Bool: instance Control.DeepSeq.NFData Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance Data.Hashable.Class.Hashable Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Classes.Eq Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Classes.Ord Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Enum.Bounded Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Enum.Enum Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Generics.Generic Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Read.Read Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: instance GHC.Show.Show Clash.Driver.Bool.OverridingBool
+ Clash.Driver.Bool: toGhcOverridingBool :: OverridingBool -> OverridingBool
+ Clash.Driver.Types: instance GHC.Generics.Generic Clash.Driver.Types.ClashOpts
+ Clash.Netlist.Util: mkLiteral :: Int -> Literal -> Expr
+ Clash.Normalize.Transformations.DEC: instance GHC.Base.Applicative Clash.Normalize.Transformations.DEC.CaseTree
+ Clash.Unique: fromGhcUnique :: Unique -> Unique
+ Clash.Unique: instance Clash.Unique.Uniquable GHC.Word.Word64
+ Clash.Unique: pattern Unique# :: Unique# -> Unique
+ Clash.Unique: type Unique# = Int#
+ Clash.Util: instance GHC.Base.Monad m => Clash.Util.MonadUnique (Control.Monad.Trans.State.Lazy.StateT Clash.Unique.Unique m)
+ Clash.Util.Supply: data Supply
+ Clash.Util.Supply: freshId :: Supply -> (Unique, Supply)
+ Clash.Util.Supply: freshId# :: Supply -> (# Unique#, Supply #)
+ Clash.Util.Supply: instance Data.Hashable.Class.Hashable Clash.Util.Supply.Block
+ Clash.Util.Supply: instance Data.Hashable.Class.Hashable Clash.Util.Supply.Supply
+ Clash.Util.Supply: instance GHC.Base.Functor Clash.Util.Supply.Stream
+ Clash.Util.Supply: instance GHC.Classes.Eq Clash.Util.Supply.Block
+ Clash.Util.Supply: instance GHC.Classes.Eq Clash.Util.Supply.Supply
+ Clash.Util.Supply: instance GHC.Classes.Ord Clash.Util.Supply.Block
+ Clash.Util.Supply: instance GHC.Classes.Ord Clash.Util.Supply.Supply
+ Clash.Util.Supply: instance GHC.Show.Show Clash.Util.Supply.Block
+ Clash.Util.Supply: instance GHC.Show.Show Clash.Util.Supply.Supply
+ Clash.Util.Supply: newSupply :: IO Supply
+ Clash.Util.Supply: splitSupply :: Supply -> (Supply, Supply)
+ Clash.Util.Supply: splitSupply# :: Supply -> (# Supply, Supply #)
- Clash.Core.VarEnv: uniqAway' :: (Uniquable a, ClashPretty a) => (Unique -> Bool) -> Int -> a -> a
+ Clash.Core.VarEnv: uniqAway' :: (Uniquable a, ClashPretty a) => (Unique -> Bool) -> Seed -> a -> a
- Clash.Driver: loadImportAndInterpret :: (MonadIO m, MonadMask m) => [String] -> [String] -> String -> ModuleName -> String -> String -> m (Either InterpreterError a)
+ Clash.Driver: loadImportAndInterpret :: (MonadIO m, MonadMask m) => [String] -> [String] -> String -> ModuleName -> String -> String -> m (Either (NonEmpty InterpreterError) a)
- Clash.Rewrite.Types: bindings :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) BindingMap
+ Clash.Rewrite.Types: bindings :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) BindingMap
- Clash.Rewrite.Types: curFun :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) (Id, SrcSpan)
+ Clash.Rewrite.Types: curFun :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) (Id, SrcSpan)
- Clash.Rewrite.Types: extra :: forall extra_a4j4N extra_a4jcz. Lens (RewriteState extra_a4j4N) (RewriteState extra_a4jcz) extra_a4j4N extra_a4jcz
+ Clash.Rewrite.Types: extra :: forall extra_a4n9o extra_a4nha. Lens (RewriteState extra_a4n9o) (RewriteState extra_a4nha) extra_a4n9o extra_a4nha
- Clash.Rewrite.Types: globalHeap :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) PrimHeap
+ Clash.Rewrite.Types: globalHeap :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) PrimHeap
- Clash.Rewrite.Types: nameCounter :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) Int
+ Clash.Rewrite.Types: nameCounter :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) Int
- Clash.Rewrite.Types: transformCounter :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) Word
+ Clash.Rewrite.Types: transformCounter :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) Word
- Clash.Rewrite.Types: transformCounters :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) (HashMap Text Word)
+ Clash.Rewrite.Types: transformCounters :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) (HashMap Text Word)
- Clash.Rewrite.Types: uniqSupply :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) Supply
+ Clash.Rewrite.Types: uniqSupply :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) Supply
- Clash.Rewrite.Types: workFreeBinders :: forall extra_a4j4N. Lens' (RewriteState extra_a4j4N) (VarEnv Bool)
+ Clash.Rewrite.Types: workFreeBinders :: forall extra_a4n9o. Lens' (RewriteState extra_a4n9o) (VarEnv Bool)
- Clash.Rewrite.Util: applyDebug :: String -> Term -> Bool -> Term -> RewriteMonad extra Term
+ Clash.Rewrite.Util: applyDebug :: TransformContext -> String -> Term -> Bool -> Term -> RewriteMonad extra Term
- Clash.Util: getUniqueM :: MonadUnique m => m Int
+ Clash.Util: getUniqueM :: MonadUnique m => m Unique
- Clash.Util.Graph: reverseTopSort :: [(Int, a)] -> [(Int, Int)] -> Either String [a]
+ Clash.Util.Graph: reverseTopSort :: [(Unique, a)] -> [(Unique, Unique)] -> Either String [a]
- Clash.Util.Graph: topSort :: [(Int, a)] -> [(Int, Int)] -> Either String [a]
+ Clash.Util.Graph: topSort :: [(Unique, a)] -> [(Unique, Unique)] -> Either String [a]
Files
- CHANGELOG.md +29/−0
- clash-lib.cabal +15/−14
- prims/common/Clash_Class_BitPack.primitives.yaml +1/−1
- prims/common/GHC_Internal_Debug_Trace.primitives.yaml +7/−0
- prims/common/GHC_Internal_Err.primitives.yaml +18/−0
- prims/common/GHC_Internal_TypeNats.primitives.yaml +17/−0
- prims/common/GHC_Magic.primitives.yaml +5/−0
- prims/common/GHC_Prim.primitives.yaml +6/−0
- prims/common/GHC_TypeNats.primitives.yaml +1/−1
- prims/commonverilog/Clash_Sized_Internal_Signed.primitives.yaml +5/−2
- prims/commonverilog/GHC_Num_Integer.primitives.yaml +2/−2
- prims/systemverilog/GHC_Prim.primitives.yaml +7/−7
- prims/verilog/GHC_Prim.primitives.yaml +7/−7
- prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml +8/−2
- prims/vhdl/GHC_Int.primitives.yaml +1/−0
- prims/vhdl/GHC_Integer_Type.primitives.yaml +8/−2
- prims/vhdl/GHC_Num_Integer.primitives.yaml +11/−5
- prims/vhdl/GHC_Prim.primitives.yaml +44/−14
- src/Clash/Backend/VHDL.hs +14/−21
- src/Clash/Backend/Verilog.hs +11/−3
- src/Clash/Core/EqSolver.hs +11/−7
- src/Clash/Core/Evaluator/Types.hs +4/−2
- src/Clash/Core/FreeVars.hs +9/−0
- src/Clash/Core/PartialEval.hs +1/−1
- src/Clash/Core/PartialEval/Monad.hs +1/−1
- src/Clash/Core/PartialEval/NormalForm.hs +1/−1
- src/Clash/Core/Term.hs +3/−1
- src/Clash/Core/TyCon.hs +6/−2
- src/Clash/Core/Type.hs +70/−36
- src/Clash/Core/TysPrim.hs +41/−32
- src/Clash/Core/Util.hs +31/−21
- src/Clash/Core/VarEnv.hs +15/−5
- src/Clash/Data/UniqMap.hs +18/−3
- src/Clash/Driver.hs +57/−48
- src/Clash/Driver/Bool.hs +34/−0
- src/Clash/Driver/Manifest.hs +1/−8
- src/Clash/Driver/Types.hs +2/−112
- src/Clash/Netlist.hs +15/−39
- src/Clash/Netlist/BlackBox.hs +27/−40
- src/Clash/Netlist/Util.hs +47/−13
- src/Clash/Normalize.hs +1/−1
- src/Clash/Normalize/PrimitiveReductions.hs +12/−8
- src/Clash/Normalize/Primitives.hs-boot +6/−0
- src/Clash/Normalize/Transformations/Case.hs +29/−20
- src/Clash/Normalize/Transformations/Cast.hs +1/−1
- src/Clash/Normalize/Transformations/DEC.hs +227/−209
- src/Clash/Normalize/Transformations/Inline.hs +13/−4
- src/Clash/Normalize/Transformations/MultiPrim.hs +5/−4
- src/Clash/Normalize/Transformations/Specialize.hs +3/−2
- src/Clash/Normalize/Util.hs +3/−5
- src/Clash/Primitives/DSL.hs +34/−21
- src/Clash/Rewrite/Types.hs +1/−1
- src/Clash/Rewrite/Util.hs +24/−7
- src/Clash/Rewrite/WorkFree.hs +12/−1
- src/Clash/Unique.hs +57/−0
- src/Clash/Util.hs +2/−2
- src/Clash/Util/Graph.hs +31/−16
- src/Clash/Util/Supply.hs +158/−0
- src/Data/Aeson/Extra.hs +6/−0
- src/Data/List/Extra.hs +14/−0
- tests/Clash/Tests/Core/Subst.hs +2/−1
- tests/Test/Clash/Rewrite.hs +5/−4
- tools/v16-upgrade-primitives.hs +5/−3
CHANGELOG.md view
@@ -1,5 +1,34 @@ # Changelog for the Clash project +## 1.8.2 *Jan 3rd 2025*++Added:+* Support for GHC 9.10 [#2758](https://github.com/clash-lang/clash-compiler/pull/2758)+* Support for GHC 9.8.4 [#2852](https://github.com/clash-lang/clash-compiler/issues/2852)+* Add `ShowX`, `NFDataX` instances for `Proxy` [#2637](https://github.com/clash-lang/clash-compiler/pull/2637)+* Added `Clash.Sized.Vector.ToTuple.vecToTuple`: a way to safely work around incomplete patterns warnings on patterns involving `Vec`tors. [#2862](https://github.com/clash-lang/clash-compiler/pull/2682)+* Added operator precedences for infix usage of functions exported from `Clash.Class.Num`: `mul`, `add`, `sub`, `satMul`, `satAdd`, `satSub`, `boundedMul`, `boundedAdd`, and `boundedSub`. This means that expressions such as `` a `add` b `mul` c `` now get parsed as `` a `add` (b `mul` c) `` instead of `` (a `add` b) `mul` c ``. [#2719](https://github.com/clash-lang/clash-compiler/pull/2719)++Changed:+* `BitVector n` now has an implementation for `ensureSpine` which ensures the constructor is present. [#2702](https://github.com/clash-lang/clash-compiler/pull/2702)+* `xToBV` is now located in `Clash.Sized.Internal.BitVector` to avoid circular dependencies. [#2702](https://github.com/clash-lang/clash-compiler/pull/2702)+* The error messages that mention the valid ranges for out-of-range inputs have been improved to be more intuitive: one of `<empty range>`, `[n]` or `[n..m]`. All _n..m_ ranges are now ordered with the lower bound on the left. [#2733](https://github.com/clash-lang/clash-compiler/pull/2733)++Fixed:+* cabal: Make `workaround-ghc-mmap-crash` a noop on non-x86_64. Fixes [#2656](https://github.com/clash-lang/clash-compiler/issues/2656)+* Clash no longer hides error messages if it fails to load external (precompiled) modules. Note: this fix only works from GHC 9.0 on. See [#2365](https://github.com/clash-lang/clash-compiler/issues/2365)+* HDL generation fails when using multiple-hidden feature in combination with synthesis attributes [#2593](https://github.com/clash-lang/clash-compiler/issues/2593)+* Clash no longer errors out in the netlist generation stage when a polymorphic function is applied to type X in one alternative of a case-statement and applied to a newtype wrapper of type X in a different alternative. See [#2828](https://github.com/clash-lang/clash-compiler/issues/2628)+* various issues with black boxes and evaluator rules for number-related primitives [#2689](https://github.com/clash-lang/clash-compiler/pull/2689)+* `genBitVector` no longer contains off-by-one error on for generated Naturals [#2704](https://github.com/clash-lang/clash-compiler/pull/2704)+* (+>>.) and (.<<+) such that they are compliant with (+>>) and (<<+) for vectors of zero length in the sense that the input vector is kept unchanged. [#2730](https://github.com/clash-lang/clash-compiler/issues/2730)+* Removed `stringsearch` dependency from `v16-upgrade-primitives`. See [#2726](https://github.com/clash-lang/clash-compiler/issues/2726)+* Bug in the compile-time evaluator [#2781](https://github.com/clash-lang/clash-compiler/issues/2781)+* Exponentiation (`Clash.Class.Exp`) is now right-associative with a precedence level of 8 (`infixr 8`). By accident, it used to lack a fixity declaration, meaning it was implicitly left-associative at level 9. [#2818](https://github.com/clash-lang/clash-compiler/pull/2818)+* Unused argument warnings on writeToBiSignal# [#2822](https://github.com/clash-lang/clash-compiler/pull/2822)+* Clash errored saying it cannot translate a globally recursive function in code that originally only contains let-bound (local) recursion [#2839](https://github.com/clash-lang/clash-compiler/issues/2839)+* Clash generates illegal Verilog names [#2845](https://github.com/clash-lang/clash-compiler/issues/2845)+ ## 1.8.1 *Nov 10th 2023* * Bump package dependencies to allow inclusion in stackage-nightly
clash-lib.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib-Version: 1.8.1+Version: 1.8.2 Synopsis: Clash: a functional hardware description language - As a library Description: Clash is a functional hardware description language that borrows both its@@ -143,7 +143,7 @@ Build-depends: aeson >= 0.6.2.0 && < 2.3, attoparsec-aeson >= 2.1 && < 2.3, aeson-pretty >= 0.8 && < 0.9,- ansi-terminal >= 0.8.0.0 && < 1.1,+ ansi-terminal >= 0.8.0.0 && < 1.2, array, async >= 2.2.0 && < 2.3, attoparsec >= 0.10.4.0 && < 0.15,@@ -151,9 +151,8 @@ base16-bytestring >= 0.1.1 && < 1.1, binary >= 0.8.5 && < 0.11, bytestring >= 0.10.0.2 && < 0.13,- clash-prelude == 1.8.1,- concurrent-supply >= 0.1.7 && < 0.2,- containers >= 0.5.0.0 && < 0.7,+ clash-prelude == 1.8.2,+ containers >= 0.5.0.0 && < 0.8, cryptohash-sha256 >= 0.11 && < 0.12, data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.7 && < 0.8,@@ -162,14 +161,15 @@ directory >= 1.2.0.1 && < 1.4, exceptions >= 0.8.3 && < 0.11.0, extra >= 1.6.17 && < 1.8,- filepath >= 1.3.0.1 && < 1.5,- ghc >= 8.6.0 && < 9.9,+ filepath >= 1.3.0.1 && < 1.6,+ ghc >= 8.6.0 && < 9.11, ghc-boot-th,- hashable >= 1.2.1.0 && < 1.5,+ ghc-prim,+ hashable >= 1.2.1.0 && < 1.6, haskell-src-meta >= 0.8 && < 0.9, hint >= 0.7 && < 0.10, infinite-list ^>= 0.1,- lens >= 4.10 && < 5.3,+ lens >= 4.10 && < 5.4, mtl >= 2.1.2 && < 2.4, ordered-containers >= 0.2 && < 0.3, prettyprinter >= 1.2.0.1 && < 1.8,@@ -177,11 +177,11 @@ pretty-show >= 1.9 && < 2.0, primitive >= 0.5.0.1 && < 1.0, string-interpolate ^>= 0.3,- template-haskell >= 2.8.0.0 && < 2.22,+ template-haskell >= 2.8.0.0 && < 2.23, temporary >= 1.2.1 && < 1.4, terminal-size >= 0.3 && < 0.4, text >= 1.2.2 && < 2.2,- time >= 1.4.0.1 && < 1.14,+ time >= 1.4.0.1 && < 1.15, transformers >= 0.5.2.0 && < 0.7, trifecta >= 1.7.1.1 && < 2.2, vector >= 0.11 && < 1.0,@@ -239,6 +239,7 @@ Clash.Debug Clash.Driver+ Clash.Driver.Bool Clash.Driver.Manifest Clash.Driver.Types @@ -305,6 +306,7 @@ Clash.Util.Eq Clash.Util.Graph Clash.Util.Interpolate+ Clash.Util.Supply Clash.Pretty Clash.Verification.Pretty@@ -343,9 +345,9 @@ yaml, bytestring, clash-lib,+ text, containers, directory,- stringsearch, Glob GHC-Options: -Wall -Wcompat default-language: Haskell2010@@ -389,7 +391,7 @@ ghc-options: -Wall -Wcompat -threaded -- Note that multiple -with-rtsopts are not cumulative, so we can't add the -- common RTS options in the unconditional GHC-Options- if flag(workaround-ghc-mmap-crash)+ if arch(x86_64) && flag(workaround-ghc-mmap-crash) GHC-Options: "-with-rtsopts=-N -xm20000000" else GHC-Options: -with-rtsopts=-N@@ -411,7 +413,6 @@ base16-bytestring, bytestring, containers,- concurrent-supply, data-default, deepseq, haskell-src-exts,
prims/common/Clash_Class_BitPack.primitives.yaml view
@@ -27,7 +27,7 @@ template: ~ARG[0] workInfo: Never - BlackBox:- name: Clash.Class.BitPack.Internal.xToBV+ name: Clash.Sized.Internal.BitVector.xToBV kind: Expression type: 'xToBV :: KnownNat n => BitVector n -> BitVector n' template: ~ARG[1]
+ prims/common/GHC_Internal_Debug_Trace.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+ name: GHC.Internal.Debug.Trace.trace+ kind: Expression+ type: 'trace :: String+ -> a -> a'+ template: ~ARG[1]+ workInfo: Never
+ prims/common/GHC_Internal_Err.primitives.yaml view
@@ -0,0 +1,18 @@+- BlackBox:+ name: GHC.Internal.Err.error+ kind: Expression+ type: 'error :: forall r a . HasCallStack => [Char] -> a'+ template: ~ERRORO+ workInfo: Constant+- BlackBox:+ name: GHC.Internal.Err.errorWithoutStackTrace+ kind: Expression+ type: 'errorWithoutStackTrace :: forall r a . [Char] -> a'+ template: ~ERRORO+ workInfo: Constant+- BlackBox:+ name: GHC.Internal.Err.undefined+ kind: Expression+ type: 'undefined :: forall r a . HasCallStack => a'+ template: ~ERRORO+ workInfo: Constant
+ prims/common/GHC_Internal_TypeNats.primitives.yaml view
@@ -0,0 +1,17 @@+- BlackBox:+ name: GHC.Internal.TypeNats.natVal+ kind: Expression+ type: 'natVal :: forall+ n proxy. KnownNat n => proxy n -> Natural'+ template: ~ARG[0]+ workInfo: Never+- Primitive:+ name: GHC.Internal.TypeNats.someNatVal+ primType: Function+ type: 'someNatVal :: Natural -> SomeNat'+ workInfo: Never+- Primitive:+ name: GHC.Internal.TypeNats.withSomeSNat+ primType: Function+ type: 'withSomeSNat :: forall rep (r :: TYPE rep). Natural -> (forall n. SNat n -> r) -> r'+ workInfo: Never
prims/common/GHC_Magic.primitives.yaml view
@@ -8,6 +8,11 @@ type: forall a. a -> a workInfo: Never - Primitive:+ name: GHC.Magic.nospec+ primType: Function+ type: forall a. a -> a+ workInfo: Never+- Primitive: name: GHC.Magic.runRW# primType: Function workInfo: Never
prims/common/GHC_Prim.primitives.yaml view
@@ -2,6 +2,12 @@ name: GHC.Prim.dataToTag# primType: Function - Primitive:+ name: GHC.Prim.dataToTagSmall#+ primType: Function+- Primitive:+ name: GHC.Prim.dataToTagLarge#+ primType: Function+- Primitive: name: GHC.Prim.tagToEnum# primType: Function - BlackBox:
prims/common/GHC_TypeNats.primitives.yaml view
@@ -11,7 +11,7 @@ type: 'someNatVal :: Natural -> SomeNat' workInfo: Never - Primitive:- name: GHC.TypeNates.withSomeSNat+ name: GHC.TypeNats.withSomeSNat primType: Function type: 'withSomeSNat :: forall rep (r :: TYPE rep). Natural -> (forall n. SNat n -> r) -> r' workInfo: Never
prims/commonverilog/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -106,8 +106,11 @@ kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)'- template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])- {1'b0}},~VAR[i][1]})~FI+ template: >-+ ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]+ ~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])+ ~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]){~VAR[i][1][~SIZE[~TYP[1]]-1]}},~VAR[i][1]})+ ~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.toEnum#
prims/commonverilog/GHC_Num_Integer.primitives.yaml view
@@ -150,8 +150,8 @@ name: GHC.Num.Integer.integerTestBit# kind: Expression type: 'integerTestBit- :: Integer -> Word# -> Bool'- template: ~VAR[input][0][~ARG[1]] == 1'b1+ :: Integer -> Word# -> Int#'+ template: "((~VAR[input][0][~ARG[1]] == 1'b1) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0)" warning: 'GHC.Num.Integer.integerTestBit#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox:
prims/systemverilog/GHC_Prim.primitives.yaml view
@@ -871,7 +871,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -942,7 +942,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1029,7 +1029,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1132,7 +1132,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1144,7 +1144,7 @@ end ~ENDGENERATE - logic [0:47] a;+ logic [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]@@ -1252,7 +1252,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1347,7 +1347,7 @@ genvar ~SYM[18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE
prims/verilog/GHC_Prim.primitives.yaml view
@@ -920,7 +920,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -991,7 +991,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1078,7 +1078,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1181,7 +1181,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1193,7 +1193,7 @@ end ~ENDGENERATE - reg [0:47] a;+ reg [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]@@ -1300,7 +1300,7 @@ genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE @@ -1395,7 +1395,7 @@ genvar ~SYM[18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19]- assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]];+ assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]]; end ~ENDGENERATE
prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -75,10 +75,16 @@ workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.*#- kind: Expression+ kind: Declaration type: '(*#) :: KnownNat n => Signed n -> Signed n -> Signed n'- template: resize(~ARG[1] * ~ARG[2], ~LIT[0])+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[1] * ~ARG[2];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; - BlackBox: name: Clash.Sized.Internal.Signed.negate# kind: Expression
prims/vhdl/GHC_Int.primitives.yaml view
@@ -4,6 +4,7 @@ type: 'I8# :: Int# -> Int8' template: resize(~ARG[0],8)+ # TODO Starting with ghc-9.0/base-4.16 this takes an I8# that is already properly sized and don't have to do this resize anymore. Same applies to the rest of this file. workInfo: Never - BlackBox: name: GHC.Int.I16#
prims/vhdl/GHC_Integer_Type.primitives.yaml view
@@ -18,10 +18,16 @@ workInfo: Never - BlackBox: name: GHC.Integer.Type.timesInteger- kind: Expression+ kind: Declaration type: 'timesInteger :: Integer -> Integer -> Integer'- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; warning: 'GHC.Integer.Type.timesInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox:
prims/vhdl/GHC_Num_Integer.primitives.yaml view
@@ -44,10 +44,16 @@ workInfo: Never - BlackBox: name: GHC.Num.Integer.integerMul- kind: Expression+ kind: Declaration type: 'integerMul :: Integer -> Integer -> Integer'- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; warning: 'GHC.Num.Integer.integerMul: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox:@@ -266,10 +272,10 @@ but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerTestBit#- kind: Expression+ kind: Declaration type: 'integerTestBit- :: Integer -> Word# -> Bool'- template: ~VAR[input][0](to_integer(~ARG[1])) = '1'+ :: Integer -> Word# -> Int#'+ template: ~RESULT <= (0 => ~VAR[input][0](to_integer(~ARG[1])), others => '0'); warning: 'GHC.Num.Integer.integerTestBit#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox:
prims/vhdl/GHC_Prim.primitives.yaml view
@@ -42,10 +42,16 @@ template: signed(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO]))) - BlackBox: name: GHC.Prim.*#- kind: Expression+ kind: Declaration type: '(*#) :: Int# -> Int# -> Int#'- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; - BlackBox: name: GHC.Prim.remInt# kind: Declaration@@ -584,7 +590,7 @@ return ~SYM[2](3,a(0 to 5)); end function; begin- ~RESULT <= resize(~SYM[3](~ARG[0](7 downto 0)),~SIZE[~TYPO]);+ ~RESULT <= resize(~SYM[3](~VAR[][0](7 downto 0)),~SIZE[~TYPO]); end block; -- clz8 end - BlackBox:@@ -628,7 +634,7 @@ return ~SYM[2](4,b(0 to 7)); end function; begin- ~RESULT <= resize(~SYM[3](~ARG[0](15 downto 0)),~SIZE[~TYPO]);+ ~RESULT <= resize(~SYM[3](~VAR[][0](15 downto 0)),~SIZE[~TYPO]); end block; -- clz16 end - BlackBox:@@ -674,7 +680,7 @@ return ~SYM[2](5,c(0 to 9)); end function; begin- ~RESULT <= resize(~SYM[3](~ARG[0](31 downto 0)),~SIZE[~TYPO]);+ ~RESULT <= resize(~SYM[3](~VAR[][0](31 downto 0)),~SIZE[~TYPO]); end block; -- clz32 end - BlackBox:@@ -941,7 +947,7 @@ signal ~GENSYM[w_reversed][5] : ~TYP[0]; begin ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate- ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[3]);+ ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); end generate; ~IF ~IW64 ~THEN ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 32)),~SIZE[~TYPO]);@@ -1273,8 +1279,14 @@ template: -~ARG[0] - BlackBox: name: GHC.Prim.timesInt8#- kind: Expression- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ kind: Declaration+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; - BlackBox: name: GHC.Prim.quotInt8# kind: Declaration@@ -1523,8 +1535,14 @@ template: -~ARG[0] - BlackBox: name: GHC.Prim.timesInt16#- kind: Expression- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ kind: Declaration+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; - BlackBox: name: GHC.Prim.quotInt16# kind: Declaration@@ -1773,8 +1791,14 @@ template: -~ARG[0] - BlackBox: name: GHC.Prim.timesInt32#- kind: Expression- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ kind: Declaration+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; - BlackBox: name: GHC.Prim.quotInt32# kind: Declaration@@ -2023,8 +2047,14 @@ template: -~ARG[0] - BlackBox: name: GHC.Prim.timesInt64#- kind: Expression- template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+ kind: Declaration+ template: |-+ ~GENSYM[~RESULT_mult][0] : block+ signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+ begin+ ~SYM[1] <= ~ARG[0] * ~ARG[1];+ ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+ end block; - BlackBox: name: GHC.Prim.quotInt64# kind: Declaration
src/Clash/Backend/VHDL.hs view
@@ -1,7 +1,7 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc.,- 2021-2023, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -38,7 +38,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List- (mapAccumL, nub, nubBy, partition, intersperse, group, sort)+ (mapAccumL, nub, nubBy, intersperse, group, sort) import Data.List.Extra ((<:>), equalLength, zipEqual) import Data.Maybe (catMaybes,mapMaybe) import Data.Monoid (Ap(Ap))@@ -254,25 +254,18 @@ | NetDecl' _ id_ hwtype _ <- ds , attr <- hwTypeAttrs hwtype] if isEmpty decs- then insts ids+ then insts ds else nest 2 (pretty nm <+> colon <+> "block" <> line <> pure decs <> (if null attrs then emptyDoc- else line <> line <> renderAttrs (TextS.pack "signal") attrs) <>- if null cds- then emptyDoc- else line <> line <> insts cds) <> line <> "begin" <>- nest 2 (line <> insts ids)+ else line <> line <> renderAttrs (TextS.pack "signal") attrs)) <> line <>+ "begin" <>+ nest 2 (line <> insts ds) <> line <> "end block" <> semi- where- (cds, ids) = partition isCompDecl ds - isCompDecl (CompDecl {}) = True- isCompDecl _ = False- addIncludes inc = includes %= (inc++) addLibraries libs = libraries %= (libs ++) addImports imps = packages %= (imps ++)@@ -1426,6 +1419,13 @@ | null attrs = emptyDoc | otherwise = renderAttrs (TextS.pack "component") [(nm, a) | a <- attrs] +decl _ (CompDecl nm ps0) =+ fmap (Just . (,0)) $ "component" <+> pretty nm <+>+ ("port" <> line <> indent 2 (tupledSemi ps <> semi))+ <> line <> "end component" <> semi+ where ps = traverse (\(t,pd,ty) -> pretty t <+> ":" <+> ppd pd <+> sizedQualTyName ty) ps0+ ppd = \case { In -> "in"; Out -> "out"}+ decl _ _ = return Nothing noEmptyInit :: VHDLM Doc -> VHDLM Doc@@ -1522,13 +1522,6 @@ inst_ (Assignment id_ Cont e) = fmap Just $ pretty id_ <+> larrow <+> align (expr_ False e) <> semi -inst_ (CompDecl nm ps0) =- fmap Just $ "component" <+> pretty nm <+>- ("port" <> line <> indent 2 (tupledSemi ps <> semi))- <> line <> "end component" <> semi- where ps = traverse (\(t,pd,ty) -> pretty t <+> ":" <+> ppd pd <+> sizedQualTyName ty) ps0- ppd = \case { In -> "in"; Out -> "out"}- inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ pretty id_ <+> larrow <+> align (vsep (sequence [expr_ False t <+> "when" <+>@@ -1863,7 +1856,7 @@ exprLit (Just (hty,sz)) (NumLit i) = case hty of Unsigned n- | i < (-2^(31 :: Integer)) -> "unsigned" <> parens ("std_logic_vector" <> parens ("signed'" <> parens lit))+ | i <= (-2^(31 :: Integer))-> "unsigned" <> parens ("std_logic_vector" <> parens ("signed'" <> parens lit)) | i < 0 -> "unsigned" <> parens ("std_logic_vector" <> parens ("to_signed" <> parens(integer i <> "," <> int n))) | i < 2^(31 :: Integer) -> "to_unsigned" <> parens (integer i <> "," <> int n) | otherwise -> "unsigned'" <> parens lit
src/Clash/Backend/Verilog.hs view
@@ -1,7 +1,7 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc.,- 2021-2023, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -49,7 +49,10 @@ import Data.Monoid (Ap(Ap)) import Data.Monoid.Extra () import Data.List- (mapAccumL, mapAccumR, nubBy, foldl')+ (mapAccumL, mapAccumR, nubBy)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import Data.List.Extra ((<:>)) import Data.Text.Lazy (pack) import qualified Data.Text.Lazy as Text@@ -1216,7 +1219,7 @@ exprLit :: Lens' s (Maybe (Maybe Int)) -> Maybe (HWType,Size) -> Literal -> Ap (State s) Doc exprLit _ Nothing (NumLit i) = integer i -exprLit k (Just (hty,sz)) (NumLit i) = case hty of+exprLit k (Just (hty,sz)) (NumLit i0) = case hty of Unsigned _ | i < 0 -> string "-" <> int sz <> string "'d" <> integer (abs i) | otherwise -> int sz <> string "'d" <> integer i@@ -1227,6 +1230,11 @@ _ -> int sz <> string "'b" <> blit where blit = bits k (toBits sz i)+ i = case hty of+ Signed _ -> let mask = 2^(sz-1) in case divMod i0 mask of+ (s,i'') | even s -> i''+ | otherwise -> i'' - mask+ _ -> i0 `mod` 2^sz exprLit k (Just (_,sz)) (BitVecLit m i) = int sz <> string "'b" <> bvlit where bvlit = bits k (toBits' sz m i)
src/Clash/Core/EqSolver.hs view
@@ -1,5 +1,5 @@ {-|- Copyright : (C) 2021 QBayLogic B.V.+ Copyright : (C) 2021-2024 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -}@@ -12,16 +12,18 @@ import Data.List.Extra (zipEqual) import Data.Maybe (catMaybes, mapMaybe) -import Clash.Core.Name (Name(nameOcc))+import Clash.Core.Name (Name(nameUniq)) import Clash.Core.Term import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet)+import Clash.Unique (fromGhcUnique) #if MIN_VERSION_ghc(9,0,0) import Clash.Core.DataCon (dcUniq)-import GHC.Builtin.Names (unsafeReflDataConKey)-import GHC.Types.Unique (getKey)+import GHC.Builtin.Names (unsafeReflDataConKey, eqPrimTyConKey, typeNatAddTyFamNameKey)+#else+import PrelNames (eqPrimTyConKey, typeNatAddTyFamNameKey) #endif -- | Data type that indicates what kind of solution (if any) was found@@ -120,7 +122,8 @@ normalizeAdd (a, b) = do (n, rhs) <- lhsLit a b case tyView rhs of- TyConApp (nameOcc -> "GHC.TypeNats.+") [left, right] -> do+ TyConApp tc [left, right]+ | nameUniq tc == fromGhcUnique typeNatAddTyFamNameKey -> do (m, o) <- lhsLit left right return (n, m, o) _ ->@@ -139,7 +142,7 @@ #if MIN_VERSION_base(4,15,0) isAbsurdPat _tcm (DataPat dc _ _) -- unsafeCoerce is not absurd in the way intended by /isAbsurdPat/- | dcUniq dc == getKey unsafeReflDataConKey+ | dcUniq dc == fromGhcUnique unsafeReflDataConKey = False #endif isAbsurdPat tcm pat =@@ -178,7 +181,8 @@ -> Maybe (Type, Type) typeEq tcm ty = case tyView (coreView tcm ty) of- TyConApp (nameOcc -> "GHC.Prim.~#") [_, _, left, right] ->+ TyConApp tc [_, _, left, right]+ | nameUniq tc == fromGhcUnique eqPrimTyConKey -> Just (coreView tcm left, coreView tcm right) _ -> Nothing
src/Clash/Core/Evaluator/Types.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-|- Copyright : (C) 2020-2022, QBayLogic B.V.+ Copyright : (C) 2020-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -11,10 +11,11 @@ -} module Clash.Core.Evaluator.Types where -import Control.Concurrent.Supply (Supply) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap (insert, lookup)+#if !MIN_VERSION_base(4,20,0) import Data.List (foldl')+#endif import Data.Maybe (fromMaybe, isJust) #if MIN_VERSION_prettyprinter(1,7,0)@@ -34,6 +35,7 @@ import Clash.Core.VarEnv import Clash.Driver.Types (BindingMap, bindingTerm) import Clash.Pretty (ClashPretty(..), fromPretty, showDoc)+import Clash.Util.Supply (Supply) whnf' :: Evaluator
src/Clash/Core/FreeVars.hs view
@@ -7,6 +7,7 @@ Free variable calculations -} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -32,7 +33,11 @@ import Control.Lens.Fold (Fold) import Control.Lens.Getter (Contravariant) import Data.Coerce+#if MIN_VERSION_ghc(9,8,4)+import qualified GHC.Data.Word64Set as IntSet+#else import qualified Data.IntSet as IntSet+#endif import Data.Monoid (All (..), Any (..)) import Clash.Core.Term (Pat (..), Term (..), TickInfo (..), Bind(..))@@ -81,7 +86,11 @@ :: (Contravariant f, Applicative f) => (forall b . Var b -> Bool) -- ^ Predicate telling whether a variable is interesting+#if MIN_VERSION_ghc(9,8,4)+ -> IntSet.Word64Set+#else -> IntSet.IntSet+#endif -- ^ Uniques of the variables in scope, used by 'termFreeVars'' -> (Var a -> f (Var a)) -> Type
src/Clash/Core/PartialEval.hs view
@@ -11,7 +11,6 @@ module Clash.Core.PartialEval where -import Control.Concurrent.Supply (Supply) import Data.IntMap.Strict (IntMap) import Clash.Core.PartialEval.AsTerm@@ -22,6 +21,7 @@ import Clash.Core.Var (Id) import Clash.Core.VarEnv (InScopeSet) import Clash.Driver.Types (Binding(..), BindingMap)+import Clash.Util.Supply (Supply) -- | An evaluator for Clash core. This consists of two functions: one to -- evaluate a term to weak-head normal form (WHNF) and another to recursively
src/Clash/Core/PartialEval/Monad.hs view
@@ -60,7 +60,6 @@ ) where import Control.Applicative (Alternative)-import Control.Concurrent.Supply (Supply) import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) import Control.Monad.IO.Class (MonadIO) @@ -85,6 +84,7 @@ import Clash.Core.VarEnv import Clash.Driver.Types (Binding(..)) import Clash.Rewrite.WorkFree (isWorkFree)+import Clash.Util.Supply (Supply) {- NOTE [RWS monad]
src/Clash/Core/PartialEval/NormalForm.hs view
@@ -30,7 +30,6 @@ , workFreeCache ) where -import Control.Concurrent.Supply (Supply) import Control.Lens (Lens', lens) import Data.IntMap.Strict (IntMap) import Data.Map.Strict (Map)@@ -44,6 +43,7 @@ import Clash.Core.Var (Id) import Clash.Core.VarEnv (VarEnv, InScopeSet) import Clash.Driver.Types (Binding(..))+import Clash.Util.Supply (Supply) type Args a = [Arg a]
src/Clash/Core/Term.hs view
@@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc.- 2021, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -63,7 +63,9 @@ import Data.Coerce (coerce) import qualified Data.DList as DList import Data.Either (lefts, rights)+#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl')+#endif import Data.Hashable (Hashable) import Data.Maybe (catMaybes) import Data.List (nub, partition)
src/Clash/Core/TyCon.hs view
@@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente- 2021, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -125,7 +125,11 @@ | Just ('(', nm1) <- T.uncons nm0 , Just (nm2, ')') <- T.unsnoc nm1 = T.all (== ',') nm2- tupleName _ = T.pack "GHC.Tuple.Prim.Tuple" `T.isPrefixOf` (nameOcc nm)+ tupleName _ =+ any (`T.isPrefixOf` (nameOcc nm)) $ map T.pack+ [ "GHC.Tuple.Prim.Tuple"+ , "GHC.Tuple.Tuple"+ ] -- | Get the DataCons belonging to a TyCon tyConDataCons :: TyCon -> [DataCon]
src/Clash/Core/Type.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc.- 2021 , QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -62,7 +62,9 @@ import Data.Binary (Binary) import Data.Coerce (coerce) import Data.Hashable (Hashable (hashWithSalt))+#if !MIN_VERSION_base(4,20,0) import Data.List (foldl')+#endif import Data.List.Extra (splitAtList) import Data.Maybe (isJust, mapMaybe) import Data.Text (Text)@@ -91,9 +93,9 @@ (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, typeNatCmpTyFamNameKey, ordLTDataConKey, ordEQDataConKey, ordGTDataConKey,- typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey)+ typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey,+ typeNatDivTyFamNameKey, typeNatModTyFamNameKey) import GHC.Types.SrcLoc (wiredInSrcSpan)-import GHC.Types.Unique (getKey) #else #if __GLASGOW_HASKELL__ >= 808 import PrelNames@@ -107,9 +109,9 @@ (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey, typeNatLeqTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, typeNatCmpTyFamNameKey,- typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey)+ typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey,+ typeNatDivTyFamNameKey, typeNatModTyFamNameKey) import SrcLoc (wiredInSrcSpan)-import Unique (getKey) #endif -- Local imports@@ -120,6 +122,7 @@ import Clash.Core.TyCon import Clash.Core.Var import qualified Clash.Data.UniqMap as UniqMap+import Clash.Unique (fromGhcUnique) import Clash.Util #if __GLASGOW_HASKELL__ <= 806@@ -452,6 +455,10 @@ funSubst _ Nothing = const Nothing funSubst tcm (Just s) = uncurry go where+ -- AnnType cannot be matched in type-families within regular GHC (as they+ -- are type synonyms) so it is fine to skip over them here.+ go (AnnType _ t1) t2 = go t1 t2+ go (VarTy nmF) ty = case lookup nmF s of Nothing -> Just ((nmF,ty):s) -- Given, for example, the type family definition:@@ -470,6 +477,10 @@ Just ty' | ty' `aeqType` ty -> Just s _ -> Nothing + -- Only look through annotations in RHS after the VarTy case, so we can+ -- preserve annotations in the substitution created by the VarTy case above+ go t1 (AnnType _ t2) = go t1 t2+ -- [Note] funSubst FunTy -- -- Whenever type classes have associated types whose instances 'map' to@@ -495,13 +506,11 @@ , argView tcm r2 -- See [Note: Eager type families] ) - go ty1@(ConstTy _) ty2 =- -- Looks through AnnType- if ty1 `aeqType` ty2 then Just s else Nothing+ go (ConstTy c1) (ConstTy c2)+ | c1 == c2 = Just s - go ty1@(LitTy _) ty2 =- -- Looks through AnnType- if ty1 `aeqType` ty2 then Just s else Nothing+ go (LitTy l1) (LitTy l2)+ | l1 == l2 = Just s go _ _ = Nothing @@ -513,22 +522,22 @@ reduceTypeFamily :: TyConMap -> Type -> Maybe Type reduceTypeFamily tcm (tyView -> TyConApp tc tys)- | nameUniq tc == getKey typeNatAddTyFamNameKey+ | nameUniq tc == fromGhcUnique typeNatAddTyFamNameKey = case mapMaybe (litView tcm) tys of [i1,i2] -> Just (LitTy (NumTy (i1 + i2))) _ -> Nothing - | nameUniq tc == getKey typeNatMulTyFamNameKey+ | nameUniq tc == fromGhcUnique typeNatMulTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 * i2))) _ -> Nothing - | nameUniq tc == getKey typeNatExpTyFamNameKey+ | nameUniq tc == fromGhcUnique typeNatExpTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 ^ i2))) _ -> Nothing - | nameUniq tc == getKey typeNatSubTyFamNameKey+ | nameUniq tc == fromGhcUnique typeNatSubTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] | let z = i1 - i2@@ -537,7 +546,7 @@ _ -> Nothing #if !MIN_VERSION_ghc(9,2,0)- | nameUniq tc == getKey typeNatLeqTyFamNameKey+ | nameUniq tc == fromGhcUnique typeNatLeqTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] | Just (FunTyCon {tyConKind = tck}) <- UniqMap.lookup tc tcm@@ -549,44 +558,53 @@ _ -> Nothing #endif - | nameUniq tc == getKey typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat"+ | nameUniq tc == fromGhcUnique typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat" = case mapMaybe (litView tcm) tys of [i1, i2] -> Just $ ConstTy $ TyCon $ case compare i1 i2 of- LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan- EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan- GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan+ LT -> Name User "GHC.Types.LT"+ (fromGhcUnique ordLTDataConKey) wiredInSrcSpan+ EQ -> Name User "GHC.Types.EQ"+ (fromGhcUnique ordEQDataConKey) wiredInSrcSpan+ GT -> Name User "GHC.Types.GT"+ (fromGhcUnique ordGTDataConKey) wiredInSrcSpan _ -> Nothing - | nameUniq tc == getKey typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"+ | nameUniq tc == fromGhcUnique typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" = case mapMaybe (symLitView tcm) tys of [s1, s2] -> Just $ ConstTy $ TyCon $ case compare s1 s2 of- LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan- EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan- GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan+ LT -> Name User "GHC.Types.LT"+ (fromGhcUnique ordLTDataConKey) wiredInSrcSpan+ EQ -> Name User "GHC.Types.EQ"+ (fromGhcUnique ordEQDataConKey) wiredInSrcSpan+ GT -> Name User "GHC.Types.GT"+ (fromGhcUnique ordGTDataConKey) wiredInSrcSpan _ -> Nothing #if MIN_VERSION_base(4,16,0)- | nameUniq tc == getKey typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"+ | nameUniq tc == fromGhcUnique typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" = case mapMaybe (charLitView tcm) tys of [s1, s2] -> Just $ ConstTy $ TyCon $ case compare s1 s2 of- LT -> Name User (showt 'LT) (getKey ordLTDataConKey) wiredInSrcSpan- EQ -> Name User (showt 'EQ) (getKey ordEQDataConKey) wiredInSrcSpan- GT -> Name User (showt 'GT) (getKey ordGTDataConKey) wiredInSrcSpan+ LT -> Name User (showt 'LT)+ (fromGhcUnique ordLTDataConKey) wiredInSrcSpan+ EQ -> Name User (showt 'EQ)+ (fromGhcUnique ordEQDataConKey) wiredInSrcSpan+ GT -> Name User (showt 'GT)+ (fromGhcUnique ordGTDataConKey) wiredInSrcSpan _ -> Nothing - | nameUniq tc == getKey typeConsSymbolTyFamNameKey -- ConsSymbol+ | nameUniq tc == fromGhcUnique typeConsSymbolTyFamNameKey -- ConsSymbol , [c0, s0] <- tys , Just c1 <- charLitView tcm c0 , Just s1 <- symLitView tcm s0 = Just (LitTy (SymTy (c1:s1))) - | nameUniq tc == getKey typeUnconsSymbolTyFamNameKey -- UnconsSymbol+ | nameUniq tc == fromGhcUnique typeUnconsSymbolTyFamNameKey -- UnconsSymbol , [s1] <- mapMaybe (symLitView tcm) tys = fromMaybe (error "reduceTypeFamily: cannot construct UnconsSymbol result") $ do FunTyCon {tyConKind = tck} <- UniqMap.lookup tc tcm@@ -604,16 +622,16 @@ [charTy,symbolTy,LitTy (CharTy c),LitTy (SymTy cs)] in pure (Just (mkTyConApp justTc [tupTcApp,tup])) - | nameUniq tc == getKey typeCharToNatTyFamNameKey -- CharToNat+ | nameUniq tc == fromGhcUnique typeCharToNatTyFamNameKey -- CharToNat , [c1] <- mapMaybe (charLitView tcm) tys = Just (LitTy (NumTy (fromIntegral (ord c1)))) - | nameUniq tc == getKey typeNatToCharTyFamNameKey -- NatToChar+ | nameUniq tc == fromGhcUnique typeNatToCharTyFamNameKey -- NatToChar , [n1] <- mapMaybe (litView tcm) tys = Just (LitTy (CharTy (chr (fromInteger n1)))) #endif - | nameUniq tc == getKey typeSymbolAppendFamNameKey -- GHC.TypeLits.AppendSymbol"+ | nameUniq tc == fromGhcUnique typeSymbolAppendFamNameKey -- GHC.TypeLits.AppendSymbol" = case mapMaybe (symLitView tcm) tys of [s1, s2] -> Just (LitTy (SymTy (s1 ++ s2)))@@ -660,20 +678,36 @@ [i1, i2] -> Just (LitTy (NumTy (i1 `lcm` i2))) _ -> Nothing - | nameOcc tc `elem` ["GHC.TypeLits.Extra.Div", "GHC.TypeNats.Div"]+ | nameOcc tc `elem` ["GHC.TypeLits.Extra.Div"] = case mapMaybe (litView tcm) tys of [i1, i2] | i2 > 0 -> Just (LitTy (NumTy (i1 `div` i2))) _ -> Nothing - | nameOcc tc `elem` ["GHC.TypeLits.Extra.Mod", "GHC.TypeNats.Mod"]+ | nameOcc tc `elem` ["GHC.TypeLits.Extra.Mod"] = case mapMaybe (litView tcm) tys of [i1, i2] | i2 > 0 -> Just (LitTy (NumTy (i1 `mod` i2))) _ -> Nothing +#if MIN_VERSION_base(4,11,0)+ | nameUniq tc == fromGhcUnique typeNatDivTyFamNameKey+ = case mapMaybe (litView tcm) tys of+ [i1, i2]+ | i2 > 0+ -> Just (LitTy (NumTy (i1 `div` i2)))+ _ -> Nothing++ | nameUniq tc == fromGhcUnique typeNatModTyFamNameKey+ = case mapMaybe (litView tcm) tys of+ [i1, i2]+ | i2 > 0+ -> Just (LitTy (NumTy (i1 `mod` i2)))+ _ -> Nothing+#endif+ | Just (FunTyCon {tyConSubst = tcSubst}) <- UniqMap.lookup tc tcm = let -- See [Note: Eager type families] tysR = map (argView tcm) tys@@ -710,7 +744,7 @@ #endif isIntegerTy :: Type -> Bool-isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == getKey integerTyConKey+isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == fromGhcUnique integerTyConKey isIntegerTy _ = False -- | Normalize a type, looking through Signals and newtypes
src/Clash/Core/TysPrim.hs view
@@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd,- 2021 , QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -47,10 +47,8 @@ #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names-import GHC.Types.Unique (getKey) #else import PrelNames-import Unique (getKey) #endif #if MIN_VERSION_ghc(8,8,0)@@ -68,17 +66,21 @@ import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var (mkTyVar)+import Clash.Unique (fromGhcUnique) import qualified Clash.Data.UniqMap as UniqMap -- | Builtin Name liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName-liftedTypeKindTyConName = mkUnsafeSystemName "Type" (getKey liftedTypeKindTyConKey)+liftedTypeKindTyConName = mkUnsafeSystemName "Type"+ (fromGhcUnique liftedTypeKindTyConKey) #if MIN_VERSION_ghc(9,2,0) typeNatKindTyConName = naturalPrimTyConName #else-typeNatKindTyConName = mkUnsafeSystemName "Nat" (getKey typeNatKindConNameKey)+typeNatKindTyConName = mkUnsafeSystemName "Nat"+ (fromGhcUnique typeNatKindConNameKey) #endif-typeSymbolKindTyConName = mkUnsafeSystemName "Symbol" (getKey typeSymbolKindConNameKey)+typeSymbolKindTyConName = mkUnsafeSystemName "Symbol"+ (fromGhcUnique typeSymbolKindConNameKey) -- | Builtin Kind liftedTypeKindTc, typeNatKindTc, typeSymbolKindTc :: TyCon@@ -96,53 +98,60 @@ floatPrimTyConName, doublePrimTyConName, naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName intPrimTyConName = mkUnsafeSystemName "GHC.Prim.Int#"- (getKey intPrimTyConKey)+ (fromGhcUnique intPrimTyConKey) #if MIN_VERSION_base(4,15,0) integerPrimTyConName = mkUnsafeSystemName "GHC.Num.Integer.Integer"- (getKey integerTyConKey)+ (fromGhcUnique integerTyConKey) #else integerPrimTyConName = mkUnsafeSystemName "GHC.Integer.Type.Integer"- (getKey integerTyConKey)+ (fromGhcUnique integerTyConKey) #endif-stringPrimTyConName = mkUnsafeSystemName "GHC.Prim.Addr#" (getKey addrPrimTyConKey)+stringPrimTyConName = mkUnsafeSystemName "GHC.Prim.Addr#"+ (fromGhcUnique addrPrimTyConKey) charPrimTyConName = mkUnsafeSystemName "GHC.Prim.Char#"- (getKey charPrimTyConKey)+ (fromGhcUnique charPrimTyConKey) wordPrimTyConName = mkUnsafeSystemName "GHC.Prim.Word#"- (getKey wordPrimTyConKey)+ (fromGhcUnique wordPrimTyConKey) int64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Int64#"- (getKey int64PrimTyConKey)+ (fromGhcUnique int64PrimTyConKey) word64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Word64#"- (getKey word64PrimTyConKey)+ (fromGhcUnique word64PrimTyConKey) floatPrimTyConName = mkUnsafeSystemName "GHC.Prim.Float#"- (getKey floatPrimTyConKey)+ (fromGhcUnique floatPrimTyConKey) doublePrimTyConName = mkUnsafeSystemName "GHC.Prim.Double#"- (getKey doublePrimTyConKey)+ (fromGhcUnique doublePrimTyConKey) #if MIN_VERSION_base(4,15,0) naturalPrimTyConName = mkUnsafeSystemName "GHC.Num.Natural.Natural"- (getKey naturalTyConKey)+ (fromGhcUnique naturalTyConKey) #else naturalPrimTyConName = mkUnsafeSystemName "GHC.Natural.Natural"- (getKey naturalTyConKey)+ (fromGhcUnique naturalTyConKey) #endif byteArrayPrimTyConName = mkUnsafeSystemName "GHC.Prim.ByteArray#"- (getKey byteArrayPrimTyConKey)+ (fromGhcUnique byteArrayPrimTyConKey) -eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (getKey eqPrimTyConKey)+eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (fromGhcUnique eqPrimTyConKey) #if !MIN_VERSION_ghc(9,2,0) voidPrimTyConName :: TyConName-voidPrimTyConName = mkUnsafeSystemName "Void#" (getKey voidPrimTyConKey)+voidPrimTyConName = mkUnsafeSystemName "Void#" (fromGhcUnique voidPrimTyConKey) #endif #if MIN_VERSION_ghc(8,8,0) int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word32PrimTyConName :: TyConName-int8PrimTyConName = mkUnsafeSystemName (showt ''Int8#) (getKey int8PrimTyConKey)-int16PrimTyConName = mkUnsafeSystemName (showt ''Int16#) (getKey int16PrimTyConKey)-int32PrimTyConName = mkUnsafeSystemName (showt ''Int32#) (getKey int32PrimTyConKey)-word8PrimTyConName = mkUnsafeSystemName (showt ''Word8#) (getKey word8PrimTyConKey)-word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#) (getKey word16PrimTyConKey)-word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#) (getKey word32PrimTyConKey)+int8PrimTyConName = mkUnsafeSystemName (showt ''Int8#)+ (fromGhcUnique int8PrimTyConKey)+int16PrimTyConName = mkUnsafeSystemName (showt ''Int16#)+ (fromGhcUnique int16PrimTyConKey)+int32PrimTyConName = mkUnsafeSystemName (showt ''Int32#)+ (fromGhcUnique int32PrimTyConKey)+word8PrimTyConName = mkUnsafeSystemName (showt ''Word8#)+ (fromGhcUnique word8PrimTyConKey)+word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#)+ (fromGhcUnique word16PrimTyConKey)+word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#)+ (fromGhcUnique word32PrimTyConKey) #endif liftedPrimTC :: TyConName@@ -167,7 +176,7 @@ let name = integerPrimTyConName uniq = nameUniq name- isDcNm = mkUnsafeSystemName (showt 'IS) (getKey integerISDataConKey)+ isDcNm = mkUnsafeSystemName (showt 'IS) (fromGhcUnique integerISDataConKey) isDc = MkData { dcName = isDcNm , dcUniq = nameUniq isDcNm@@ -179,7 +188,7 @@ , dcArgStrict = [Strict] , dcFieldLabels = [] }- ipDcNm = mkUnsafeSystemName (showt 'IP) (getKey integerIPDataConKey)+ ipDcNm = mkUnsafeSystemName (showt 'IP) (fromGhcUnique integerIPDataConKey) ipDc = MkData { dcName = ipDcNm , dcUniq = nameUniq ipDcNm@@ -191,7 +200,7 @@ , dcArgStrict = [Strict] , dcFieldLabels = [] }- inDcNm = mkUnsafeSystemName (showt 'IN) (getKey integerINDataConKey)+ inDcNm = mkUnsafeSystemName (showt 'IN) (fromGhcUnique integerINDataConKey) inDc = MkData { dcName = inDcNm , dcUniq = nameUniq inDcNm@@ -211,7 +220,7 @@ let name = naturalPrimTyConName uniq = nameUniq name- nsDcNm = mkUnsafeSystemName (showt 'NS) (getKey naturalNSDataConKey)+ nsDcNm = mkUnsafeSystemName (showt 'NS) (fromGhcUnique naturalNSDataConKey) nsDc = MkData { dcName = nsDcNm , dcUniq = nameUniq nsDcNm@@ -223,7 +232,7 @@ , dcArgStrict = [Strict] , dcFieldLabels = [] }- nbDcNm = mkUnsafeSystemName (showt 'NB) (getKey naturalNBDataConKey)+ nbDcNm = mkUnsafeSystemName (showt 'NB) (fromGhcUnique naturalNBDataConKey) nbDc = MkData { dcName = nbDcNm , dcUniq = nameUniq nbDcNm
src/Clash/Core/Util.hs view
@@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente,- 2021-2023, QBayLogic B.V.,+ 2021-2024, QBayLogic B.V., 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -18,7 +18,12 @@ module Clash.Core.Util where -import Control.Concurrent.Supply (Supply, freshId)+import Control.Exception.Base (patError)+#if MIN_VERSION_base(4,16,0)+import GHC.Prim.Panic (absentError)+#else+import Control.Exception.Base (absentError)+#endif import Control.Monad.Trans.Except (Except, throwE, runExcept) import Data.Bifunctor (first, second) import qualified Data.HashSet as HashSet@@ -31,14 +36,15 @@ import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import qualified Data.Text as T+import Data.Text.Extra (showt)+import GHC.Real+ (divZeroError, overflowError, ratioZeroDenominatorError, underflowError) import GHC.Stack (HasCallStack) #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (ipClassKey)-import GHC.Types.Unique (getKey) #else import PrelNames (ipClassKey)-import Unique (getKey) #endif import Clash.Core.DataCon@@ -58,8 +64,13 @@ import Clash.Core.VarEnv import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (traceIf)+import Clash.Unique (fromGhcUnique) import Clash.Util+import Clash.Util.Supply (Supply, freshId) +import {-# SOURCE #-} qualified Clash.Normalize.Primitives as Primitives+import Clash.XException (errorX)+ -- | Rebuild a let expression / let expressions by taking the SCCs of a list -- of bindings and remaking Let (NonRec ...) ... and Let (Rec ...) ... --@@ -480,24 +491,23 @@ } undefinedPrims :: [T.Text]-undefinedPrims =- [ "Clash.Normalize.Primitives.undefined"- , "Control.Exception.Base.absentError"- , "Control.Exception.Base.patError"- , "GHC.Err.error"- , "GHC.Err.errorWithoutStackTrace"- , "GHC.Err.undefined"- , "GHC.Prim.Panic.absentError"- , "GHC.Real.divZeroError"- , "GHC.Real.overflowError"- , "GHC.Real.ratioZeroDenominatorError"- , "GHC.Real.underflowError"+undefinedPrims = fmap showt+ [ 'Primitives.undefined+ , 'patError+ , 'error+ , 'errorWithoutStackTrace+ , 'undefined+ , 'absentError+ , 'divZeroError+ , 'overflowError+ , 'ratioZeroDenominatorError+ , 'underflowError ] undefinedXPrims :: [T.Text]-undefinedXPrims =- [ "Clash.Normalize.Primitives.undefinedX"- , "Clash.XException.errorX"+undefinedXPrims = fmap showt+ [ 'Primitives.undefinedX+ , 'errorX ] substArgTys@@ -627,7 +637,7 @@ -- isHidden :: Name a -> [Type] -> Bool isHidden nm [a1, a2] | TyConApp a2Nm _ <- tyView a2 =- nameOcc nm == "GHC.Classes.(%,%)"+ nameOcc nm `elem` ["GHC.Classes.(%,%)", "GHC.Classes.CTuple2"] && splitTy (tyView (stripIP a1)) && nameOcc a2Nm == "Clash.Signal.Internal.KnownDomain" isHidden _ _ = False@@ -673,7 +683,7 @@ -- | Strip implicit parameter wrappers (IP) stripIP :: Type -> Type stripIP t@(tyView -> TyConApp tcNm [_a1, a2]) =- if nameUniq tcNm == getKey ipClassKey then a2 else t+ if nameUniq tcNm == fromGhcUnique ipClassKey then a2 else t stripIP t = t -- | Do an inverse topological sorting of the let-bindings in a let-expression
src/Clash/Core/VarEnv.hs view
@@ -103,6 +103,9 @@ import qualified Data.List as List import qualified Data.List.Extra as List import Data.Maybe (fromMaybe)+#if MIN_VERSION_ghc(9,8,4)+import Data.Word (Word64)+#endif #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter@@ -385,14 +388,21 @@ -- * InScopeSet +type Seed+#if MIN_VERSION_ghc(9,8,4)+ = Word64+#else+ = Int+#endif+ -- | Set of variables that is in scope at some point ----- The 'Int' is a kind of hash-value used to generate new uniques. It should+-- The 'Seed' is a kind of hash-value used to generate new uniques. It should -- never be zero -- -- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 for the -- motivation-data InScopeSet = InScopeSet VarSet {-# UNPACK #-} !Int+data InScopeSet = InScopeSet VarSet {-# UNPACK #-} !Seed deriving (Generic, NFData, Binary) instance ClashPretty InScopeSet where@@ -412,7 +422,7 @@ -> [Var a] -> InScopeSet extendInScopeSetList (InScopeSet inScope n) vs =- InScopeSet (List.foldl' extendVarSet inScope vs) (n + length vs)+ InScopeSet (List.foldl' extendVarSet inScope vs) (n + fromIntegral (length vs)) -- | Union two sets of in scope variables unionInScope@@ -484,7 +494,7 @@ :: (Uniquable a, ClashPretty a) => (Unique -> Bool) -- ^ Unique in scope test- -> Int+ -> Seed -- ^ Seed -> a -> a@@ -510,7 +520,7 @@ deriveUnique :: Unique- -> Int+ -> Seed -> Unique deriveUnique i delta = i + delta
src/Clash/Data/UniqMap.hs view
@@ -42,11 +42,16 @@ import Prelude hiding (elem, filter, lookup, notElem, null) import Control.DeepSeq (NFData)-import Data.Binary (Binary)+import Data.Binary (Binary (..)) import Data.Bifunctor (first) import Data.Function (on)+#if MIN_VERSION_ghc(9,8,4)+import GHC.Data.Word64Map.Strict (Word64Map)+import qualified GHC.Data.Word64Map.Strict as IntMap+#else import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap+#endif import qualified Data.List as List (foldl') #if !MIN_VERSION_containers(0,6,2)@@ -66,17 +71,27 @@ -- uniqueable and provide their own key, however a unique can be associated -- with any value. newtype UniqMap a+#if MIN_VERSION_ghc(9,8,4)+ = UniqMap { uniqMapToIntMap :: Word64Map a }+#else = UniqMap { uniqMapToIntMap :: IntMap a }+#endif deriving stock Traversable deriving newtype- ( Binary- , Foldable+ ( Foldable , Functor , Monoid , NFData , Semigroup , Show )+#if MIN_VERSION_ghc(9,8,4)+instance Binary a => Binary (UniqMap a) where+ put (UniqMap m) = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)+ get = fmap (UniqMap . IntMap.fromDistinctAscList) get+#else+ deriving newtype Binary+#endif instance ClashPretty a => ClashPretty (UniqMap a) where clashPretty xs =
src/Clash/Driver.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , QBayLogic, Google Inc.- 2020-2023, QBayLogic,+ 2020-2024, QBayLogic, 2022 , Google Inc. License : BSD2 (see the file LICENSE)@@ -12,23 +12,23 @@ -} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} module Clash.Driver where import Control.Concurrent (MVar, modifyMVar, modifyMVar_, newMVar, withMVar) import Control.Concurrent.Async (mapConcurrently_)-import qualified Control.Concurrent.Supply as Supply import Control.DeepSeq-import Control.Exception (throw)+import Control.Exception (throw, Exception) import qualified Control.Monad as Monad import Control.Monad (unless, foldM, forM, filterM)-import Control.Monad.Catch (MonadMask)+import Control.Monad.Catch (MonadMask, MonadThrow (throwM)) import Control.Monad.Extra (whenM, ifM, unlessM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (evalState, get)@@ -49,6 +49,8 @@ import Data.Proxy (Proxy(..)) import Data.List (intercalate) import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map.Ordered as OMap import Data.Map.Ordered.Extra ()@@ -85,12 +87,10 @@ #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqTyConKey, ipClassKey)-import GHC.Types.Unique (getKey) import GHC.Types.SrcLoc (SrcSpan) #else import PrelNames (eqTyConKey, ipClassKey)-import Unique (getKey) import SrcLoc (SrcSpan) #endif@@ -144,12 +144,13 @@ import qualified Clash.Primitives.Xilinx.ClockGen as P import Clash.Primitives.Types import Clash.Signal.Internal-import Clash.Unique (Unique, getUnique)+import Clash.Unique (Unique, getUnique, fromGhcUnique) import Clash.Util (ClashException(..), reportTimeDiff, wantedLanguageExtensions, unwantedLanguageExtensions, curLoc) import Clash.Util.Graph (reverseTopSort) import qualified Clash.Util.Interpolate as I+import qualified Clash.Util.Supply as Supply -- | Worker function of 'splitTopEntityT' splitTopAnn@@ -216,8 +217,8 @@ -- * HasCallStack shouldNotHavePortName :: Type -> Bool shouldNotHavePortName (tyView -> TyConApp (nameUniq -> tcUniq) tcArgs)- | tcUniq == getKey eqTyConKey = True- | tcUniq == getKey ipClassKey+ | tcUniq == fromGhcUnique eqTyConKey = True+ | tcUniq == fromGhcUnique ipClassKey , [LitTy (SymTy "callStack"), _] <- tcArgs = True shouldNotHavePortName _ = False @@ -539,7 +540,7 @@ -- ^ Function name -> String -- ^ Type name ('BlackBoxFunction' or 'TemplateFunction')- -> m (Either Hint.InterpreterError a)+ -> m (Either (NonEmpty Hint.InterpreterError) a) loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do Hint.liftIO $ Monad.when debugIsOn $ putStr "Hint: Interpreting " >> putStrLn (qualMod ++ "." ++ funcName)@@ -552,10 +553,10 @@ Hint.unsafeInterpret funcName typ case bbfE of- Left _ -> do+ Left globalException -> do -- Try to interpret module as a local module, not yet present in the -- global package database(s).- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do+ localRes <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do Hint.reset iPaths1 <- (iPaths0++) <$> Hint.get Hint.searchPath Hint.set [ Hint.searchPath Hint.:= iPaths1@@ -563,8 +564,13 @@ Hint.loadModules [qualMod] Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", qualMod] Hint.unsafeInterpret funcName typ- Right _ -> do- return bbfE++ case localRes of+ Left localException -> pure (Left (globalException :| [localException]))+ Right res -> pure (Right res)++ Right res -> do+ return (Right res) where langExts = map Hint.asExtension $ map show wantedLanguageExtensions ++@@ -631,11 +637,7 @@ let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs -- Compile a blackbox template function or fetch it from an already compiled file. r <- go interpreterArgs source- processHintError- (show bbGenName)- bbName- id- r+ processHintErrors (show bbGenName) bbName r pure (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName (hash source, bbFunc)) where@@ -656,7 +658,7 @@ go :: [String] -> Maybe Text- -> IO (Either Hint.InterpreterError BlackBoxFunction)+ -> IO (Either (NonEmpty Hint.InterpreterError) BlackBoxFunction) go args (Just source') = do -- Create a temporary directory with user module in it, add it to the -- list of import direcotries, and run as if it were a "normal" compiled@@ -709,7 +711,8 @@ Text.writeFile (modDir </> last modNames <.> "hs") source loadImportAndInterpret (tmpDir':idirs) iArgs topDir qualMod funcName "TemplateFunction" let hsh = hash (qualMod, source)- processHintError (show bbGenName) pNm (BBFunction (Data.Text.unpack pNm) hsh) r+ BBFunction (Data.Text.unpack pNm) hsh <$>+ processHintErrors (show bbGenName) pNm r parseBB ((THaskell,bbGenName),Nothing) = do let BlackBoxFunctionName modNames funcName = bbGenName qualMod = intercalate "." modNames@@ -720,37 +723,43 @@ Just f -> pure f Nothing -> do r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction"- processHintError (show bbGenName) pNm id r+ processHintErrors (show bbGenName) pNm r pure (BBFunction (Data.Text.unpack pNm) hsh tf) compilePrimitive _ _ _ (Primitive pNm wf typ) = return (Primitive pNm wf typ) {-# SCC compilePrimitive #-} -processHintError- :: Monad m- => String- -> Data.Text.Text- -> (t -> r)- -> Either Hint.InterpreterError t- -> m r-processHintError fun bb go r = case r of- Left (Hint.GhcException err) ->- error' "GHC Exception" err- Left (Hint.NotAllowed err) ->- error' "NotAllowed error" err- Left (Hint.UnknownError err) ->- error' "an unknown error" err- Left (Hint.WontCompile ghcErrs) ->- error' "compilation errors" (intercalate "\n\n" $ map Hint.errMsg ghcErrs)- Right f ->- return $ go f+newtype HintError = HintError String deriving (Exception)++instance Show HintError where+ showsPrec :: Int -> HintError -> ShowS+ showsPrec _ (HintError e) = showString e++processHintErrors ::+ (MonadThrow m, Monad m) =>+ -- | Function to interpret+ String ->+ -- | BlackBox function name+ Data.Text.Text ->+ -- | Hint result+ Either (NonEmpty Hint.InterpreterError) t ->+ m t+processHintErrors fun bb r = case r of+ Left es -> throwM $ HintError (formatExceptions (NonEmpty.toList es))+ Right f -> pure f where- error' errType report =- error $ unwords [ "Encountered", errType, "while compiling blackbox template"- , "function", show fun, "for function", show bb ++ "."- , "Compilation reported: \n\n" ++ report ]+ formatExceptions es = [I.i|+ Encountered one or more exceptions when compiling blackbox template function+ '#{fun}' for function '#{bb}'.+ |] <> "\n\n" <> intercalate "\n\n" (map formatException es) + formatException e = [I.i|+ Encountered:++ #{e}+ |]+ -- | Pretty print Components to HDL Documents createHDL :: Backend backend@@ -1120,8 +1129,8 @@ mapFrom tops = let- topIndices = HashMap.fromList (zip (map topToUnique tops) [(0 :: Int)..])+ topIndices = HashMap.fromList (zip (map topToUnique tops) [(0 :: Unique)..]) nonOrdered = HashMap.fromListWith (<>) (map (second pure) edges)- orderFunc k = fromMaybe (-1) (HashMap.lookup k topIndices)+ orderFunc k = HashMap.lookup k topIndices in HashMap.map (List.sortOn orderFunc) nonOrdered
+ src/Clash/Driver/Bool.hs view
@@ -0,0 +1,34 @@+{-|+ Copyright : (C) 2024, Martijn Bastiaan+ License : BSD2 (see the file LICENSE)+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}++module Clash.Driver.Bool where++import Control.DeepSeq (NFData)+import Data.Hashable (Hashable)+import GHC.Generics (Generic)++#if MIN_VERSION_ghc(9,4,0)+import qualified GHC.Data.Bool as Ghc+#elif MIN_VERSION_ghc(9,0,0)+import qualified GHC.Utils.Misc as Ghc+#else+import qualified Util as Ghc+#endif++data OverridingBool = Auto | Never | Always+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Hashable, Generic, NFData)++toGhcOverridingBool :: OverridingBool -> Ghc.OverridingBool+toGhcOverridingBool Auto = Ghc.Auto+toGhcOverridingBool Never = Ghc.Never+toGhcOverridingBool Always = Ghc.Always++fromGhcOverridingBool :: Ghc.OverridingBool -> OverridingBool+fromGhcOverridingBool Ghc.Auto = Auto+fromGhcOverridingBool Ghc.Never = Never+fromGhcOverridingBool Ghc.Always = Always
src/Clash/Driver/Manifest.hs view
@@ -54,6 +54,7 @@ import Clash.Annotations.TopEntity.Extra () import Clash.Backend (Backend (hdlType), Usage (External)) import Clash.Core.Name (nameOcc)+import Clash.Driver.Bool (OverridingBool(..)) import Clash.Driver.Types import Clash.Primitives.Types import Clash.Core.Var (Id, varName)@@ -65,14 +66,6 @@ import Clash.Primitives.Util (hashCompiledPrimMap) import Clash.Signal (VDomainConfiguration(..)) import Clash.Util.Graph (callGraphBindings)--#if MIN_VERSION_ghc(9,4,0)-import GHC.Data.Bool (OverridingBool(..))-#elif MIN_VERSION_ghc(9,0,0)-import GHC.Utils.Misc (OverridingBool(..))-#else-import Util (OverridingBool(..))-#endif data PortDirection = In | Out | InOut
src/Clash/Driver/Types.hs view
@@ -45,15 +45,12 @@ #if MIN_VERSION_ghc(9,4,0) import GHC.Types.Basic (InlineSpec) import GHC.Types.SrcLoc (SrcSpan)-import GHC.Data.Bool (OverridingBool(..)) #elif MIN_VERSION_ghc(9,0,0) import GHC.Types.Basic (InlineSpec) import GHC.Types.SrcLoc (SrcSpan)-import GHC.Utils.Misc (OverridingBool(..)) #else import BasicTypes (InlineSpec) import SrcLoc (SrcSpan)-import Util (OverridingBool(..)) #endif import Clash.Annotations.BitRepresentation.Internal (CustomReprs)@@ -64,6 +61,7 @@ import Clash.Core.TyCon (TyConMap, TyConName) import Clash.Core.Var (Id) import Clash.Core.VarEnv (VarEnv)+import Clash.Driver.Bool (OverridingBool(..)) import Clash.Netlist.BlackBox.Types (HdlSyn (..)) import {-# SOURCE #-} Clash.Netlist.Types (PreserveCase(..), TopEntityT) import Clash.Primitives.Types (CompiledPrimMap)@@ -401,115 +399,7 @@ -- ^ Timescale precision set in Verilog files. E.g., setting this would sets -- the second part of @`timescale 100fs/100fs@. }- deriving (Show)--instance NFData ClashOpts where- rnf o =- opt_werror o `deepseq`- opt_inlineLimit o `deepseq`- opt_specLimit o `deepseq`- opt_inlineFunctionLimit o `deepseq`- opt_inlineConstantLimit o `deepseq`- opt_evaluatorFuelLimit o `deepseq`- opt_cachehdl o `deepseq`- opt_clear o `deepseq`- opt_primWarn o `deepseq`- opt_color o `seq`- opt_intWidth o `deepseq`- opt_hdlDir o `deepseq`- opt_hdlSyn o `deepseq`- opt_errorExtra o `deepseq`- opt_importPaths o `deepseq`- opt_componentPrefix o `deepseq`- opt_newInlineStrat o `deepseq`- opt_escapedIds o `deepseq`- opt_lowerCaseBasicIds o `deepseq`- opt_ultra o `deepseq`- opt_forceUndefined o `deepseq`- opt_checkIDir o `deepseq`- opt_aggressiveXOpt o `deepseq`- opt_aggressiveXOptBB o `deepseq`- opt_inlineWFCacheLimit o `deepseq`- opt_edalize o `deepseq`- opt_renderEnums o `deepseq`- opt_timescalePrecision o `deepseq`- ()--instance Eq ClashOpts where- s0 == s1 =- opt_werror s0 == opt_werror s1 &&- opt_inlineLimit s0 == opt_inlineLimit s1 &&- opt_specLimit s0 == opt_specLimit s1 &&- opt_inlineFunctionLimit s0 == opt_inlineFunctionLimit s1 &&- opt_inlineConstantLimit s0 == opt_inlineConstantLimit s1 &&- opt_evaluatorFuelLimit s0 == opt_evaluatorFuelLimit s1 &&- opt_cachehdl s0 == opt_cachehdl s1 &&- opt_clear s0 == opt_clear s1 &&- opt_primWarn s0 == opt_primWarn s1 &&- (opt_color s0 `eqOverridingBool` opt_color s1) &&- opt_intWidth s0 == opt_intWidth s1 &&- opt_hdlDir s0 == opt_hdlDir s1 &&- opt_hdlSyn s0 == opt_hdlSyn s1 &&- opt_errorExtra s0 == opt_errorExtra s1 &&- opt_importPaths s0 == opt_importPaths s1 &&- opt_componentPrefix s0 == opt_componentPrefix s1 &&- opt_newInlineStrat s0 == opt_newInlineStrat s1 &&- opt_escapedIds s0 == opt_escapedIds s1 &&- opt_lowerCaseBasicIds s0 == opt_lowerCaseBasicIds s1 &&- opt_ultra s0 == opt_ultra s1 &&- opt_forceUndefined s0 == opt_forceUndefined s1 &&- opt_checkIDir s0 == opt_checkIDir s1 &&- opt_aggressiveXOpt s0 == opt_aggressiveXOpt s1 &&- opt_aggressiveXOptBB s0 == opt_aggressiveXOptBB s1 &&- opt_inlineWFCacheLimit s0 == opt_inlineWFCacheLimit s1 &&- opt_edalize s0 == opt_edalize s1 &&- opt_renderEnums s0 == opt_renderEnums s1 &&- opt_timescalePrecision s0 == opt_timescalePrecision s1-- where- eqOverridingBool :: OverridingBool -> OverridingBool -> Bool- eqOverridingBool Auto Auto = True- eqOverridingBool Always Always = True- eqOverridingBool Never Never = True- eqOverridingBool _ _ = False--instance Hashable ClashOpts where- hashWithSalt s ClashOpts {..} =- s `hashWithSalt`- opt_werror `hashWithSalt`- opt_inlineLimit `hashWithSalt`- opt_specLimit `hashWithSalt`- opt_inlineFunctionLimit `hashWithSalt`- opt_inlineConstantLimit `hashWithSalt`- opt_evaluatorFuelLimit `hashWithSalt`- opt_cachehdl `hashWithSalt`- opt_clear `hashWithSalt`- opt_primWarn `hashOverridingBool`- opt_color `hashWithSalt`- opt_intWidth `hashWithSalt`- opt_hdlDir `hashWithSalt`- opt_hdlSyn `hashWithSalt`- opt_errorExtra `hashWithSalt`- opt_importPaths `hashWithSalt`- opt_componentPrefix `hashWithSalt`- opt_newInlineStrat `hashWithSalt`- opt_escapedIds `hashWithSalt`- opt_lowerCaseBasicIds `hashWithSalt`- opt_ultra `hashWithSalt`- opt_forceUndefined `hashWithSalt`- opt_checkIDir `hashWithSalt`- opt_aggressiveXOpt `hashWithSalt`- opt_aggressiveXOptBB `hashWithSalt`- opt_inlineWFCacheLimit `hashWithSalt`- opt_edalize `hashWithSalt`- opt_renderEnums `hashWithSalt`- opt_timescalePrecision- where- hashOverridingBool :: Int -> OverridingBool -> Int- hashOverridingBool s1 Auto = hashWithSalt s1 (0 :: Int)- hashOverridingBool s1 Always = hashWithSalt s1 (1 :: Int)- hashOverridingBool s1 Never = hashWithSalt s1 (2 :: Int)- infixl 0 `hashOverridingBool`+ deriving (Show, Eq, NFData, Generic, Hashable) defClashOpts :: ClashOpts defClashOpts
src/Clash/Netlist.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc.,- 2021-2022, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -41,14 +41,8 @@ (listToMaybe, fromMaybe) import qualified Data.Map.Ordered as OMap import qualified Data.Set as Set-import Data.Primitive.ByteArray (ByteArray (..)) import qualified Data.Text as StrictText import GHC.Stack (HasCallStack)-#if MIN_VERSION_base(4,15,0)-import GHC.Num.Integer (Integer (..))-#else-import GHC.Integer.GMP.Internals (Integer (..), BigNat (..))-#endif #if MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable (ppr, showSDocUnsafe)@@ -825,30 +819,7 @@ -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations mkExpr _ _ _ (stripTicks -> Core.Literal l) = do iw <- Lens.view intWidth- case l of- IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])- IntLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])- WordLiteral w -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, [])- Int64Literal i -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, [])- Word64Literal w -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, [])-#if MIN_VERSION_ghc(8,8,0)- Int8Literal i -> return (HW.Literal (Just (Signed 8,8)) $ NumLit i, [])- Int16Literal i -> return (HW.Literal (Just (Signed 16,16)) $ NumLit i, [])- Int32Literal i -> return (HW.Literal (Just (Signed 32,32)) $ NumLit i, [])- Word8Literal w -> return (HW.Literal (Just (Unsigned 8,8)) $ NumLit w, [])- Word16Literal w -> return (HW.Literal (Just (Unsigned 16,16)) $ NumLit w, [])- Word32Literal w -> return (HW.Literal (Just (Unsigned 32,32)) $ NumLit w, [])-#endif- CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, [])- FloatLiteral w -> return (HW.Literal (Just (BitVector 32,32)) (NumLit $ toInteger w), [])- DoubleLiteral w -> return (HW.Literal (Just (BitVector 64,64)) (NumLit $ toInteger w), [])- NaturalLiteral n -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit n, [])-#if MIN_VERSION_base(4,15,0)- ByteArrayLiteral (ByteArray ba) -> return (HW.Literal Nothing (NumLit (IP ba)),[])-#else- ByteArrayLiteral (ByteArray ba) -> return (HW.Literal Nothing (NumLit (Jp# (BN# ba))),[])-#endif- StringLiteral s -> return (HW.Literal Nothing $ StringLit s, [])+ return (mkLiteral iw l, []) mkExpr bbEasD declType bndr app = let (appF,args,ticks) = collectArgsTicks app@@ -1032,18 +1003,23 @@ dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprsFiltered)- LT -> error $ $(curLoc) ++ "Over-applied constructor"- GT -> error $ $(curLoc) ++ "Under-applied constructor"+ LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+ GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm Product _ _ dcArgs -> case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)- LT -> error $ $(curLoc) ++ "Over-applied constructor"- GT -> error $ $(curLoc) ++ "Under-applied constructor"+ LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+ GT -> error $ unlines [ $(curLoc) ++ "Under-applied constructor:" ++ StrictText.unpack dcNm+ , "dcArgs=" ++ unlines [" - " ++ show x | x <- dcArgs]+ , "argExprs=" ++ unlines [" - " ++ show x | x <- argExprs]+ , "hWTysFilt=" ++ unlines [" - " ++ show x | x <- hWTysFiltered]+ , "argExprsFilt=" ++ unlines [" - " ++ show x | x <- argExprsFiltered]+ ] CustomProduct _ _ _ _ dcArgs -> case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)- LT -> error $ $(curLoc) ++ "Over-applied constructor"- GT -> error $ $(curLoc) ++ "Under-applied constructor"+ LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+ GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm Sum _ _ -> return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) []) CustomSP _ _ _ dcArgsTups -> do@@ -1055,8 +1031,8 @@ case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType, dcI)) argExprsFiltered)- LT -> error $ $(curLoc) ++ "Over-applied constructor"- GT -> error $ $(curLoc) ++ "Under-applied constructor"+ LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+ GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm CustomSum _ _ _ _ -> return (HW.DataCon dstHType (DC (dstHType, dcTag dc - 1)) [])
src/Clash/Netlist/BlackBox.hs view
@@ -3,7 +3,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , Google Inc.,- 2021-2023, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -29,7 +29,6 @@ import Control.Monad.Extra (concatMapM) import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (first, second)-import Data.Char (ord) import Data.Either (lefts, partitionEithers) import Data.Foldable (for_) import qualified Data.HashMap.Lazy as HashMap@@ -53,13 +52,6 @@ , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid)) import System.IO (hPutStrLn, stderr, hFlush, hIsTerminalDevice)-#if MIN_VERSION_ghc(9,4,0)-import GHC.Data.Bool (OverridingBool(..))-#elif MIN_VERSION_ghc(9,0,0)-import GHC.Utils.Misc (OverridingBool(..))-#else-import Util (OverridingBool(..))-#endif import Clash.Annotations.Primitive ( PrimitiveGuard(HasBlackBox, DontTranslate)@@ -68,7 +60,7 @@ import Clash.Core.DataCon as D (dcTag) import Clash.Core.FreeVars (freeIds) import Clash.Core.HasType-import Clash.Core.Literal as L (Literal (..))+import Clash.Core.Literal as C (Literal (..)) import Clash.Core.Name (Name (..), mkUnsafeSystemName) import qualified Clash.Netlist.Id as Id@@ -93,6 +85,7 @@ import qualified Clash.Backend as Backend import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (debugIsOn)+import Clash.Driver.Bool (OverridingBool(..)) import Clash.Driver.Types (ClashOpts(opt_primWarn, opt_color, opt_werror)) import Clash.Netlist.BlackBox.Types as B@@ -263,6 +256,7 @@ (C.Literal _,_) -> True _ -> False + mkArgument :: TextS.Text -- ^ Blackbox function name@@ -291,36 +285,9 @@ Just hwTy -> case collectArgsTicks e of (C.Var v,[],_) -> do return ((Identifier (Id.unsafeFromCoreId v) Nothing,hwTy,False),[])- (C.Literal (IntegerLiteral i),[],_) ->- return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[])- (C.Literal (IntLiteral i), [],_) ->- return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[])- (C.Literal (WordLiteral w), [],_) ->- return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[])- (C.Literal (CharLiteral c), [],_) ->- return ((N.Literal (Just (Unsigned 21,21)) (N.NumLit . toInteger $ ord c),hwTy,True),[])- (C.Literal (StringLiteral s),[],_) ->- return ((N.Literal Nothing (N.StringLit s),hwTy,True),[])- (C.Literal (Int64Literal i), [],_) ->- return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[])- (C.Literal (Word64Literal i), [],_) ->- return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[])-#if MIN_VERSION_base(4,16,0)- (C.Literal (Int8Literal i), [],_) ->- return ((N.Literal (Just (Signed 8,8)) (N.NumLit i),hwTy,True),[])- (C.Literal (Int16Literal i), [],_) ->- return ((N.Literal (Just (Signed 16,16)) (N.NumLit i),hwTy,True),[])- (C.Literal (Int32Literal i), [],_) ->- return ((N.Literal (Just (Signed 16,16)) (N.NumLit i),hwTy,True),[])- (C.Literal (Word8Literal i), [],_) ->- return ((N.Literal (Just (Unsigned 8,8)) (N.NumLit i),hwTy,True),[])- (C.Literal (Word16Literal i), [],_) ->- return ((N.Literal (Just (Unsigned 16,16)) (N.NumLit i),hwTy,True),[])- (C.Literal (Word32Literal i), [],_) ->- return ((N.Literal (Just (Unsigned 32,32)) (N.NumLit i),hwTy,True),[])-#endif- (C.Literal (NaturalLiteral n), [],_) ->- return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit n),hwTy,True),[])+ (C.Literal l,[],_) ->+ return ((mkLiteral iw l,hwTy,True),[])+ (Prim pinfo,args,ticks) -> withTicks ticks $ \tickDecls -> do (e',d) <- mkPrimitive True False Concurrent (NetlistId bndr ty) pinfo args tickDecls case e' of@@ -577,6 +544,26 @@ iw <- Lens.view intWidth return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[]) [Right _,Left scrut] -> do+ tcm <- Lens.view tcCache+ let scrutTy = inferCoreTypeOf tcm scrut+ scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+ (scrutExpr,scrutDecls) <-+ mkExpr False Concurrent (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut+ case scrutExpr of+ Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls)+ _ -> do+ tmpRhs <- Id.make "c$dtt_rhs"+ let assignTy = case declType of { Concurrent -> Cont ; Sequential -> Proc Blocking }+ netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr+ return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)+ _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args)++ | pNm `elem`+ ["GHC.Prim.dataToTagSmall#", "GHC.Prim.dataToTagLarge#"] -> case args of+ [Right _, Right _,Left (Data dc)] -> do+ iw <- Lens.view intWidth+ return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[])+ [Right _, Right _,Left scrut] -> do tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
src/Clash/Netlist/Util.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd 2017-2018, Google Inc.- 2021-2023, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -39,13 +39,14 @@ import Control.Monad.Trans.Except (ExceptT (..), runExcept, runExceptT, throwE) import Data.Bifunctor (second)+import Data.Char (ord) import Data.Either (partitionEithers) import Data.Foldable (Foldable(toList)) import Data.Functor (($>)) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import qualified Data.IntSet as IntSet+import Data.Primitive.ByteArray (ByteArray (..)) import Control.Applicative (Alternative((<|>))) import Data.List (unzip4, partition) import qualified Data.List as List@@ -59,6 +60,13 @@ import Data.Text.Extra (showt) import Data.Text.Lazy (toStrict) import Data.Text.Prettyprint.Doc.Extra++#if MIN_VERSION_base(4,15,0)+import GHC.Num.Integer (Integer (..))+#else+import GHC.Integer.GMP.Internals (Integer (..), BigNat (..))+#endif+ import GHC.Stack (HasCallStack) #if MIN_VERSION_ghc(9,0,0)@@ -563,10 +571,10 @@ let -- Free FVs in the LHS and RHS of the constraint that are not the -- in the set of universal type variables of the constructor. ty1FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce)- IntSet.empty)+ mempty) ty1 ty2FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce)- IntSet.empty)+ mempty) ty2 -- Determine whether `eTV` can be generated from one side of a@@ -1168,15 +1176,13 @@ -- | Declare uses which occur as a result of a component being instantiated, -- for example the following design (verilog) ----- @--- module f ( input p; output reg r ) ... endmodule------ module top ( ... )--- ...--- f f_inst ( .p(p), .r(foo));--- ...--- endmodule--- @+-- > module f ( input p; output reg r ) ... endmodule+-- >+-- > module top ( ... )+-- > ...+-- > f f_inst ( .p(p), .r(foo));+-- > ...+-- > endmodule -- -- would declare a usage of foo, since it is assigned by @f_inst@. --@@ -2116,3 +2122,31 @@ expandTopEntity _ _ topEntityM = error ("expandTopEntity expects a Synthesize annotation, but got: " <> show topEntityM)++-- | Convert a Core 'C.Literal' to a Netlist v'HW.Literal'+mkLiteral :: Int -- ^ int width+ -> C.Literal -> HW.Expr+mkLiteral iw lit = case lit of+ C.IntegerLiteral i -> HW.Literal (Just (Signed iw,iw)) $ NumLit i+ C.IntLiteral i -> HW.Literal (Just (Signed iw,iw)) $ NumLit i+ C.WordLiteral w -> HW.Literal (Just (Unsigned iw,iw)) $ NumLit w+ C.Int64Literal i -> HW.Literal (Just (Signed 64,64)) $ NumLit i+ C.Word64Literal w -> HW.Literal (Just (Unsigned 64,64)) $ NumLit w+#if MIN_VERSION_ghc(8,8,0)+ C.Int8Literal i -> HW.Literal (Just (Signed 8,8)) $ NumLit i+ C.Int16Literal i -> HW.Literal (Just (Signed 16,16)) $ NumLit i+ C.Int32Literal i -> HW.Literal (Just (Signed 32,32)) $ NumLit i+ C.Word8Literal w -> HW.Literal (Just (Unsigned 8,8)) $ NumLit w+ C.Word16Literal w -> HW.Literal (Just (Unsigned 16,16)) $ NumLit w+ C.Word32Literal w -> HW.Literal (Just (Unsigned 32,32)) $ NumLit w+#endif+ C.CharLiteral c -> HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c+ C.FloatLiteral w -> HW.Literal (Just (BitVector 32,32)) (NumLit $ toInteger w)+ C.DoubleLiteral w -> HW.Literal (Just (BitVector 64,64)) (NumLit $ toInteger w)+ C.NaturalLiteral n -> HW.Literal (Just (Unsigned iw,iw)) $ NumLit n+#if MIN_VERSION_base(4,15,0)+ C.ByteArrayLiteral (ByteArray ba) -> HW.Literal Nothing (NumLit (IP ba))+#else+ C.ByteArrayLiteral (ByteArray ba) -> HW.Literal Nothing (NumLit (Jp# (BN# ba)))+#endif+ C.StringLiteral s -> HW.Literal Nothing $ StringLit s
src/Clash/Normalize.hs view
@@ -16,7 +16,6 @@ module Clash.Normalize where -import Control.Concurrent.Supply (Supply) import Control.Exception (throw) import qualified Control.Lens as Lens import Control.Monad (when)@@ -80,6 +79,7 @@ (apply, isUntranslatableType, runRewriteSession) import Clash.Util import Clash.Util.Interpolate (i)+import Clash.Util.Supply (Supply) import Data.Binary (encode) import qualified Data.ByteString as BS
src/Clash/Normalize/PrimitiveReductions.hs view
@@ -1,7 +1,7 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2016 , Myrtle Software Ltd,- 2021 , QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -45,7 +45,12 @@ import Data.Bifunctor (second) import Data.List (mapAccumR) import Data.List.Extra (zipEqual)+#if MIN_VERSION_base(4,20,0)+import qualified Data.List.NonEmpty as NE hiding (unzip)+import qualified Data.Functor as NE+#else import qualified Data.List.NonEmpty as NE+#endif import qualified Data.Maybe as Maybe import Data.Semigroup (sconcat) import Data.Text.Extra (showt)@@ -55,13 +60,11 @@ import GHC.Builtin.Names (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)-import GHC.Types.Unique (getKey) import GHC.Types.SrcLoc (wiredInSrcSpan) #else import PrelNames (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)-import Unique (getKey) import SrcLoc (wiredInSrcSpan) #endif @@ -93,20 +96,21 @@ import Clash.Normalize.Types import Clash.Rewrite.Types import Clash.Rewrite.Util+import Clash.Unique (fromGhcUnique) import Clash.Util import qualified Clash.Util.Interpolate as I typeNatAdd :: TyConName typeNatAdd =- Name User "GHC.TypeNats.+" (getKey typeNatAddTyFamNameKey) wiredInSrcSpan+ Name User "GHC.TypeNats.+" (fromGhcUnique typeNatAddTyFamNameKey) wiredInSrcSpan typeNatMul :: TyConName typeNatMul =- Name User "GHC.TypeNats.*" (getKey typeNatMulTyFamNameKey) wiredInSrcSpan+ Name User "GHC.TypeNats.*" (fromGhcUnique typeNatMulTyFamNameKey) wiredInSrcSpan typeNatSub :: TyConName typeNatSub =- Name User "GHC.TypeNats.-" (getKey typeNatSubTyFamNameKey) wiredInSrcSpan+ Name User "GHC.TypeNats.-" (fromGhcUnique typeNatSubTyFamNameKey) wiredInSrcSpan vecHeadPrim :: TyConName@@ -1072,7 +1076,7 @@ replace_intElement tcm iDc iTy oldA elIndex = case0 where case0 = Maybe.fromMaybe (error "replace_intElement: faild to build Truce DC") $ do- boolTc <- UniqMap.lookup (getKey boolTyConKey) tcm+ boolTc <- UniqMap.lookup (fromGhcUnique boolTyConKey) tcm [_,trueDc] <- pure (tyConDataCons boolTc) let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) return (Case (mkApps eqInt [ Left i@@ -1181,7 +1185,7 @@ index_intElement tcm iDc iTy (cur,elIndex) next = case0 where case0 = Maybe.fromMaybe (error "reduceIndex_int: faild to build True DC") $ do- boolTc <- UniqMap.lookup (getKey boolTyConKey) tcm+ boolTc <- UniqMap.lookup (fromGhcUnique boolTyConKey) tcm [_,trueDc] <- pure (tyConDataCons boolTc) let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) return (Case (mkApps eqInt [ Left i
+ src/Clash/Normalize/Primitives.hs-boot view
@@ -0,0 +1,6 @@+module Clash.Normalize.Primitives where++import Clash.Core.Term (PrimInfo)++undefined :: PrimInfo+undefinedX :: PrimInfo
src/Clash/Normalize/Transformations/Case.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc.,- 2021-2022, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> Transformations on case-expressions@@ -26,6 +26,12 @@ , elimExistentials ) where +import Control.Exception.Base (patError)+#if MIN_VERSION_base(4,16,0)+import GHC.Prim.Panic (absentError)+#else+import Control.Exception.Base (absentError)+#endif import qualified Control.Lens as Lens import Control.Monad.State.Strict (evalState) import Data.Bifunctor (second)@@ -80,6 +86,8 @@ import Clash.Rewrite.WorkFree import Clash.Util (curLoc) +import Clash.XException (errorX)+ -- | Move a Case-decomposition from the subject of a Case-decomposition to the -- alternatives caseCase :: HasCallStack => NormRewrite@@ -266,24 +274,23 @@ -- 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" ->+ | primName pInfo == Text.showt '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)- | primName pInfo `elem` ["Control.Exception.Base.absentError"- ,"GHC.Prim.Panic.absentError"] ->+ | primName pInfo == Text.showt 'absentError -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,msgOrCallStack] in changed e1 -- 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.errorWithoutStackTrace"] ->+ | primName pInfo `elem` [ Text.showt 'patError+ , Text.showt 'undefined+ , Text.showt 'errorWithoutStackTrace] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [repTy,Right ty,msgOrCallStack] in changed e1@@ -297,7 +304,7 @@ -- 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"+ | primName pInfo == Text.showt 'errorX -> 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,@@ -454,18 +461,20 @@ -- | Remove non-reachable alternatives. For example, consider: ----- data STy ty where--- SInt :: Int -> STy Int--- SBool :: Bool -> STy Bool+-- @+-- data STy ty where+-- SInt :: Int -> STy Int+-- SBool :: Bool -> STy Bool ----- f :: STy ty -> ty--- f (SInt b) = b + 1--- f (SBool True) = False--- f (SBool False) = True--- {-# NOINLINE f #-}+-- f :: STy ty -> ty+-- f (SInt b) = b + 1+-- f (SBool True) = False+-- f (SBool False) = True+-- {\-\# NOINLINE f \#-\} ----- g :: STy Int -> Int--- g = f+-- g :: STy Int -> Int+-- g = f+-- @ -- -- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore -- unreachable. Additional information can be found at:@@ -498,7 +507,7 @@ -- GHC generates Core that looks like: -- -- @--- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of+-- f = \\(x :: Unsigned 4) -> case x == fromInteger 3 of -- False -> case x == fromInteger 2 of -- False -> case x == fromInteger 1 of -- False -> case x == fromInteger 0 of@@ -515,7 +524,7 @@ -- This transformation transforms the above Core to the saner: -- -- @--- f = \(x :: Unsigned 4) -> case x of+-- f = \\(x :: Unsigned 4) -> case x of -- _ -> error "incomplete case" -- 0 -> fromInteger 3 -- 1 -> fromInteger 2
src/Clash/Normalize/Transformations/Cast.hs view
@@ -42,7 +42,7 @@ -- transforms to: -- @ -- y = f' a--- where f' x' = (\x -> g x) (cast x')+-- where f' x' = (\\x -> g x) (cast x') -- @ -- -- The reason d'etre for this transformation is that we hope to end up with
src/Clash/Normalize/Transformations/DEC.hs view
@@ -1,6 +1,6 @@ {-| Copyright : (C) 2015-2016, University of Twente,- 2021-2022, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. 2022, LumiGuide Fietsdetectie B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -31,12 +31,15 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-} module Clash.Normalize.Transformations.DEC ( disjointExpressionConsolidation ) where -import Control.Concurrent.Supply (splitSupply)+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif import Control.Lens ((^.), _1) import qualified Control.Lens as Lens import qualified Control.Monad as Monad@@ -48,14 +51,15 @@ import qualified Data.Graph as Graph import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap-import qualified Data.IntSet as IntSet import qualified Data.List as List import qualified Data.List.Extra as List import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import Data.Monoid (All(..)) import qualified Data.Text as Text+import Data.Text.Extra (showt) import GHC.Stack (HasCallStack)+import qualified Language.Haskell.TH as TH #if MIN_VERSION_ghc(9,6,0) import GHC.Core.Make (chunkify, mkChunkified)@@ -72,13 +76,14 @@ #endif -- internal-import Clash.Core.DataCon (DataCon)+import Clash.Core.DataCon (DataCon) import Clash.Core.Evaluator.Types (whnf') import Clash.Core.FreeVars (termFreeVars', typeFreeVars', localVarsDoNotOccurIn) import Clash.Core.HasType import Clash.Core.Literal (Literal(..))-import Clash.Core.Name (nameOcc)+import Clash.Core.Name (OccName, nameOcc)+import Clash.Core.Pretty (showPpr) import Clash.Core.Term ( Alt, LetBinding, Pat(..), PrimInfo(..), Term(..), TickInfo(..) , collectArgs, collectArgsTicks, mkApps, mkTicks, patIds, stripTicks)@@ -86,7 +91,7 @@ import Clash.Core.Type (Type, TypeView (..), isPolyFunTy, mkTyConApp, splitFunForallTy, tyView) import Clash.Core.Util (mkInternalVar, mkSelectorCase, sccLetBindings)-import Clash.Core.Var (isGlobalId, isLocalId, varName)+import Clash.Core.Var (Id, isGlobalId, isLocalId, varName) import Clash.Core.VarEnv ( InScopeSet, elemInScopeSet, extendInScopeSet, extendInScopeSetList , notElemInScopeSet, unionInScope)@@ -95,10 +100,27 @@ import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators (bottomupR) import Clash.Rewrite.Types-import Clash.Rewrite.Util (changed, isUntranslatableType)+import Clash.Rewrite.Util (changed, isFromInt, isUntranslatableType) import Clash.Rewrite.WorkFree (isConstant) import Clash.Util (MonadUnique, curLoc)+import Clash.Util.Supply (splitSupply) +-- primitives+import qualified Clash.Sized.Internal.BitVector+import qualified Clash.Sized.Internal.Index+import qualified Clash.Sized.Internal.Signed+import qualified Clash.Sized.Internal.Unsigned+import qualified GHC.Base+import qualified GHC.Classes+#if MIN_VERSION_base(4,15,0)+import qualified GHC.Num.Integer+#else+-- interger-gmp primitives are defined in the hidden module GHC.Integer.Type,+-- but exported from GHC.Integer+import qualified GHC.Integer as GHC.Integer.Type+#endif+import qualified GHC.Prim+ -- | This transformation lifts applications of global binders out of -- alternatives of case-statements. --@@ -122,6 +144,24 @@ -- B -> f_out -- C -> h x -- @+--+-- Though that's a lie. It actually converts it into:+--+-- @+-- let f_tupIn = case x of {A -> (3,y); B -> (x,x)}+-- f_arg0 = case f_tupIn of (l,_) -> l+-- f_arg1 = case f_tupIn of (_,r) -> r+-- f_out = f f_arg0 f_arg1+-- in case x of+-- A -> f_out+-- B -> f_out+-- C -> h x+-- @+--+-- In order to share the expression that's in the subject of the case expression,+-- and to share the /decoder/ circuit that logic synthesis will create to map the+-- bits of the subject expression to the bits needed to make the selection in the+-- multiplexer. disjointExpressionConsolidation :: HasCallStack => NormRewrite disjointExpressionConsolidation ctx@(TransformContext isCtx _) e@(Case _scrut _ty _alts@(_:_:_)) = do -- Collect all (the applications of) global binders (and certain primitives)@@ -134,11 +174,13 @@ else do -- For every to-lift expression create (the generalization of): --- -- let fargs = case x of {A -> (3,y); B -> (x,x)}- -- in f (fst fargs) (snd fargs)+ -- let f_tupIn = case x of {A -> (3,y); B -> (x,x)}+ -- f_arg0 = case f_tupIn of (l,_) -> l+ -- f_arg1 = case f_tupIn of (_,r) -> r+ -- in f f_arg0 f_arg0 --- -- the let-expression is not created when `f` has only one (selectable)- -- argument+ -- if an argument is non-representable, the case-expression is inlined,+ -- and no let-binding will be created for it. -- -- NB: mkDisJointGroup needs the context InScopeSet, isCtx, to determine -- whether expressions reference variables from the context, or@@ -174,11 +216,8 @@ -- Make the let-binder for the lifted expressions mkFunOut tcm isN ((fun,_),(eLifted,_)) = do let ty = inferCoreTypeOf tcm eLifted- nm = case collectArgs fun of- (Var v,_) -> nameOcc (varName v)- (Prim p,_) -> primName p- _ -> "complex_expression_"- nm1 = last (Text.splitOn "." nm) `Text.append` "Out"+ nm = decFunName fun+ nm1 = nm `Text.append` "_out" nm2 <- mkInternalVar isN nm1 ty return (extendInScopeSet isN nm2,nm2) @@ -233,12 +272,26 @@ disjointExpressionConsolidation _ e = return e {-# SCC disjointExpressionConsolidation #-} +decFunName :: Term -> OccName+decFunName fun = last . Text.splitOn "." $ case collectArgs fun of+ (Var v, _) -> nameOcc (varName v)+ (Prim p, _) -> primName p+ _ -> "complex_expression"+ data CaseTree a = Leaf a | LB [LetBinding] (CaseTree a) | Branch Term [(Pat,CaseTree a)] deriving (Eq,Show,Functor,Foldable) +instance Applicative CaseTree where+ pure = Leaf+ liftA2 f (Leaf a) (Leaf b) = Leaf (f a b)+ liftA2 f (LB lb c1) (LB _ c2) = LB lb (liftA2 f c1 c2)+ liftA2 f (Branch scrut alts1) (Branch _ alts2) =+ Branch scrut (zipWith (\(p1,a1) (_,a2) -> (p1,liftA2 f a1 a2)) alts1 alts2)+ liftA2 _ _ _ = error "CaseTree.liftA2: internal error, this should not happen."+ -- | Test if a 'CaseTree' collected from an expression indicates that -- application of a global binder is disjoint: occur in separate branches of a -- case-expression.@@ -253,18 +306,6 @@ go (Branch _ [(_,x)]) = go x go b@(Branch _ (_:_:_)) = allEqual (map Either.rights (Foldable.toList b)) --- Remove empty branches from a 'CaseTree'-removeEmpty :: Eq a => CaseTree [a] -> CaseTree [a]-removeEmpty l@(Leaf _) = l-removeEmpty (LB lb ct) =- case removeEmpty ct of- Leaf [] -> Leaf []- ct' -> LB lb ct'-removeEmpty (Branch s bs) =- case filter ((/= (Leaf [])) . snd) (map (second removeEmpty) bs) of- [] -> Leaf []- bs' -> Branch s bs'- -- | Test if all elements in a list are equal to each other. allEqual :: Eq a => [a] -> Bool allEqual [] = True@@ -273,7 +314,7 @@ -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of an expression. Also substitute truly disjoint applications of globals by a -- reference to a lifted out application.-collectGlobals'+collectGlobals :: InScopeSet -> [(Term,Term)] -- ^ Substitution of (applications of) a global binder by a reference to a@@ -282,10 +323,8 @@ -- ^ List of already seen global binders -> Term -- ^ The expression- -> Bool- -- ^ Whether expression is constant -> NormalizeSession (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))])-collectGlobals' is0 substitution seen (Case scrut ty alts) _eIsConstant = do+collectGlobals is0 substitution seen (Case scrut ty alts) = do rec (alts1, isAlts, collectedAlts) <- collectGlobalsAlts is0 substitution seen scrut1 alts (scrut1, isScrut, collectedScrut) <-@@ -294,8 +333,8 @@ , unionInScope isAlts isScrut , collectedAlts ++ collectedScrut ) -collectGlobals' is0 substitution seen e@(collectArgsTicks -> (fun, args@(_:_), ticks)) eIsconstant- | not eIsconstant = do+collectGlobals is0 substitution seen e@(collectArgsTicks -> (fun, args@(_:_), ticks))+ | not (isConstant e) = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings evaluate <- Lens.view evaluator@@ -317,10 +356,10 @@ (args1,isArgs,collectedArgs) <- collectGlobalsArgs is0 substitution seen args let seenInArgs = map fst collectedArgs ++ seen- isInteresting <- interestingToLift is0 eval fun args ticks+ isInteresting = interestingToLift is0 eval fun args ticks case isInteresting of Just fun1 | fun1 `notElem` seenInArgs -> do- let e1 = Maybe.fromMaybe (mkApps fun1 args1) (List.lookup fun1 substitution)+ let e1 = Maybe.fromMaybe (mkApps (mkTicks fun1 ticks) args1) (List.lookup fun1 substitution) -- This function is lifted out an environment with the currently 'seen' -- binders. When we later apply substitution, we need to start with this -- environment, otherwise we perform incorrect substitutions in the@@ -333,7 +372,7 @@ -- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed. -- -- I think we should be able to do better, but perhaps we cannot fix it here.-collectGlobals' is0 substitution seen (Letrec lbs body) _eIsConstant = do+collectGlobals is0 substitution seen (Letrec lbs body) = do let is1 = extendInScopeSetList is0 (map fst lbs) (body1,isBody,collectedBody) <- collectGlobals is1 substitution seen body@@ -344,27 +383,11 @@ , map (second (second (LB lbs1))) (collectedBody ++ collectedBndrs) ) -collectGlobals' is0 substitution seen (Tick t e) eIsConstant = do- (e1,is1,collected) <- collectGlobals' is0 substitution seen e eIsConstant+collectGlobals is0 substitution seen (Tick t e) = do+ (e1,is1,collected) <- collectGlobals is0 substitution seen e return (Tick t e1, is1, collected) -collectGlobals' is0 _ _ e _ = return (e,is0,[])---- | Collect 'CaseTree's for (potentially) disjoint applications of globals out--- of an expression. Also substitute truly disjoint applications of globals by a--- reference to a lifted out application.-collectGlobals- :: InScopeSet- -> [(Term,Term)]- -- ^ Substitution of (applications of) a global binder by a reference to- -- a lifted term.- -> [Term]- -- ^ List of already seen global binders- -> Term- -- ^ The expression- -> NormalizeSession (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))])-collectGlobals inScope substitution seen e =- collectGlobals' inScope substitution seen e (isConstant e)+collectGlobals is0 _ _ e = return (e,is0,[]) -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of a list of application arguments. Also substitute truly disjoint@@ -466,90 +489,94 @@ -- function-position\", return a let-expression: where the let-binding holds -- a case-expression selecting between the distinct arguments of the case-tree, -- and the body is an application of the term applied to the shared arguments of--- the case tree, and projections of let-binding corresponding to the distinct--- argument positions.+-- the case tree, and variable references to the created let-bindings.+--+-- case-expressions whose type would be non-representable are not let-bound,+-- but occur directly in the argument position of the application in the body+-- of the let-expression. mkDisjointGroup :: InScopeSet -- ^ Variables in scope at the very top of the case-tree, i.e., the original -- expression- -> (Term,([Term],CaseTree [(Either Term Type)]))+ -> (Term,([Term],CaseTree [Either Term Type])) -- ^ Case-tree of arguments belonging to the applied term. -> NormalizeSession (Term,[Term]) mkDisjointGroup inScope (fun,(seen,cs)) = do tcm <- Lens.view tcCache- let argss = Foldable.toList cs- argssT = zip [0..] (List.transpose argss)- (sharedT,distinctT) = List.partition (areShared tcm inScope . fmap (first stripTicks) . snd) argssT- -- TODO: find a better solution than "maybe undefined fst . uncons"- shared = map (second (maybe (error "impossible") fst . List.uncons)) sharedT- distinct = map (Either.lefts) (List.transpose (map snd distinctT))- cs' = fmap (zip [0..]) cs- cs'' = removeEmpty- $ fmap (Either.lefts . map snd)- (if null shared- then cs'- else fmap (filter (`notElem` shared)) cs')- (distinctCaseM,distinctProjections) <- case distinct of- -- only shared arguments: do nothing.- [] -> return (Nothing,[])- -- Create selectors and projections- (uc:_) -> do- let argTys = map (inferCoreTypeOf tcm) uc- disJointSelProj inScope argTys cs''- let newArgs = mkDJArgs 0 shared distinctProjections- case distinctCaseM of- Just lb -> return (Letrec [lb] (mkApps fun newArgs), seen)- Nothing -> return (mkApps fun newArgs, seen)+ let funName = decFunName fun+ argLen = case Foldable.toList cs of+ [] -> error "mkDisjointGroup: no disjoint groups"+ l:_ -> length l+ csT :: [CaseTree (Either Term Type)] -- "Transposed" 'CaseTree [Either Term Type]'+ csT = map (\i -> fmap (!!i) cs) [0..(argLen-1)] -- sequenceA does the wrong thing+ (lbs,newArgs) <- List.mapAccumRM (\lbs (c,pos) -> do+ let cL = Foldable.toList c+ case (cL, areShared tcm inScope (fmap (first stripTicks) cL)) of+ (Right ty:_, True) ->+ return (lbs,Right ty)+ (Right _:_, False) ->+ error ("mkDisjointGroup: non-equal type arguments: " <>+ showPpr (Either.rights cL))+ (Left tm:_, True) ->+ return (lbs,Left tm)+ (Left tm:_, False) -> do+ let ty = inferCoreTypeOf tcm tm+ let err = error ("mkDisjointGroup: mixed type and term arguments: " <> show cL)+ (lbM,arg) <- disJointSelProj inScope ty (Either.fromLeft err <$> c) funName pos+ case lbM of+ Just lb -> return (lb:lbs, Left arg)+ _ -> return (lbs, Left arg)+ ([], _) ->+ error "mkDisjointGroup: no arguments"+ ) [] (zip csT [0..])+ let funApp = mkApps fun newArgs+ tupTcm <- Lens.view tupleTcCache+ case lbs of+ [] ->+ return (funApp, seen)+ [(v,(ty,ct))] -> do+ let e = genCase tcm tupTcm ty [ty] (fmap (:[]) ct)+ return (Letrec [(v,e)] funApp, seen)+ _ -> do+ let (vs,zs) = unzip lbs+ csL :: [CaseTree Term]+ (tys,csL) = unzip zs+ csLT :: CaseTree [Term]+ csLT = fmap ($ []) (foldr1 (liftA2 (.)) (fmap (fmap (:)) csL))+ bigTupTy = mkBigTupTy tcm tupTcm tys+ ct = genCase tcm tupTcm bigTupTy tys csLT+ tupIn <- mkInternalVar inScope (funName <> "_tupIn") bigTupTy+ projections <-+ Monad.zipWithM (\v n ->+ (v,) <$> mkBigTupSelector inScope tcm tupTcm (Var tupIn) tys n)+ vs [0..]+ return (Letrec ((tupIn,ct):projections) funApp, seen) --- | Create a single selector for all the representable distinct arguments by--- selecting between tuples. This selector is only ('Just') created when the--- number of representable uncommmon arguments is larger than one, otherwise it--- is not ('Nothing').------ It also returns:------ * For all the non-representable distinct arguments: a selector--- * For all the representable distinct arguments: a projection out of the tuple--- created by the larger selector. If this larger selector does not exist, a--- single selector is created for the single representable distinct argument.+-- | Create a selector for the case-tree of the argument. If the argument is+-- representable create a let-binding for the created selector, and return+-- a variable reference to this let-binding. If the argument is not representable+-- return the selector directly. disJointSelProj :: InScopeSet- -> [Type]- -- ^ Types of the arguments- -> CaseTree [Term]- -- The case-tree of arguments- -> NormalizeSession (Maybe LetBinding,[Term])-disJointSelProj _ _ (Leaf []) = return (Nothing,[])-disJointSelProj inScope argTys cs = do- tcm <- Lens.view tcCache+ -> Type+ -- ^ Types of the argument+ -> CaseTree Term+ -- ^ The case-tree of argument+ -> OccName+ -- ^ Name of the lifted function+ -> Word+ -- ^ Position of the argument+ -> NormalizeSession (Maybe (Id, (Type, CaseTree Term)),Term)+disJointSelProj inScope argTy cs funName argN = do+ tcm <- Lens.view tcCache tupTcm <- Lens.view tupleTcCache- let maxIndex = length argTys - 1- css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex]- (untran,tran) <- List.partitionM (isUntranslatableType False . snd) (zip [0..] argTys)- let untranCs = map (css!!) (map fst untran)- untranSels = zipWith (\(_,ty) cs' -> genCase tcm tupTcm ty [ty] cs')- untran untranCs- (lbM,projs) <- case tran of- [] -> return (Nothing,[])- [(i,ty)] -> return (Nothing,[genCase tcm tupTcm ty [ty] (css!!i)])- tys -> do- let m = length tys- (tyIxs,tys') = unzip tys- tupTy = mkBigTupTy tcm tupTcm tys'- cs' = fmap (\es -> map (es !!) tyIxs) cs- djCase = genCase tcm tupTcm tupTy tys' cs'- scrutId <- mkInternalVar inScope "tupIn" tupTy- projections <- mapM (mkBigTupSelector inScope tcm tupTcm (Var scrutId) tys') [0..m-1]- return (Just (scrutId,djCase),projections)- let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs-- return (lbM,selProjs)- where- tranOrUnTran _ [] projs = projs- tranOrUnTran _ sels [] = map snd sels- tranOrUnTran n ((ut,s):uts) (p:projs)- | n == ut = s : tranOrUnTran (n+1) uts (p:projs)- | otherwise = p : tranOrUnTran (n+1) ((ut,s):uts) projs+ let sel = genCase tcm tupTcm argTy [argTy] (fmap (:[]) cs)+ untran <- isUntranslatableType False argTy+ case untran of+ True -> return (Nothing, sel)+ False -> do+ argId <- mkInternalVar inScope (funName <> "_arg" <> showt argN) argTy+ return (Just (argId,(argTy,cs)), Var argId) -- | Arguments are shared between invocations if: --@@ -569,7 +596,7 @@ areShared tcm inScope xs@(x:_) = noFV1 && (isProof x || allEqual xs) where noFV1 = case x of- Right ty -> getAll (Lens.foldMapOf (typeFreeVars' isLocallyBound IntSet.empty)+ Right ty -> getAll (Lens.foldMapOf (typeFreeVars' isLocallyBound mempty) (const (All False)) ty) Left tm -> getAll (Lens.foldMapOf (termFreeVars' isLocallyBound) (const (All False)) tm)@@ -577,22 +604,10 @@ isLocallyBound v = isLocalId v && v `notElemInScopeSet` inScope isProof (Left co) = case tyView (inferCoreTypeOf tcm co) of- TyConApp (nameOcc -> "GHC.Types.~") _ -> True+ TyConApp (nameOcc -> nm) _ -> nm == fromTHName ''(~) _ -> False isProof _ = False --- | Create a list of arguments given a map of positions to common arguments,--- and a list of arguments-mkDJArgs :: Int -- ^ Current position- -> [(Int,Either Term Type)] -- ^ map from position to common argument- -> [Term] -- ^ (projections for) distinct arguments- -> [Either Term Type]-mkDJArgs _ cms [] = map snd cms-mkDJArgs _ [] uncms = map Left uncms-mkDJArgs n ((m,x):cms) (y:uncms)- | n == m = x : mkDJArgs (n+1) cms (y:uncms)- | otherwise = Left y : mkDJArgs (n+1) ((m,x):cms) uncms- -- | Create a case-expression that selects between the distinct arguments given -- a case-tree genCase :: TyConMap@@ -687,8 +702,11 @@ -- This holds for all global functions, and certain primitives. Currently those -- primitives are: ----- * All non-power-of-two multiplications--- * All division-like operations with a non-power-of-two divisor+-- * All non-cheap multiplications+-- * All division-like operations with a non-cheap divisor+--+-- Multiplying/dividing by zero or powers of two are considered cheap and+-- isn't lifted out. interestingToLift :: InScopeSet -- ^ in scope@@ -700,99 +718,99 @@ -- ^ Arguments -> [TickInfo] -- ^ Tick annoations- -> RewriteMonad extra (Maybe Term)+ -> Maybe Term interestingToLift inScope _ e@(Var v) _ ticks = if NoDeDup `notElem` ticks && (isGlobalId v || v `elemInScopeSet` inScope)- then pure (Just e)- else pure Nothing+ then (Just e)+ else Nothing interestingToLift inScope eval e@(Prim pInfo) args ticks | NoDeDup `notElem` ticks = do let anyArgNotConstant = any (not . isConstant) lArgs case List.lookup (primName pInfo) interestingPrims of- Just t | t || anyArgNotConstant -> pure (Just e)- _ | DeDup `elem` ticks -> pure (Just e)- _ -> do- let isInteresting = (\(x, y, z) -> interestingToLift inScope eval x y z) . collectArgsTicks+ Just t | t || anyArgNotConstant -> (Just e)+ _ | DeDup `elem` ticks -> (Just e)+ _ -> if isHOTy (coreTypeOf pInfo) then do- anyInteresting <- List.anyM (fmap Maybe.isJust . isInteresting) lArgs- if anyInteresting then pure (Just e) else pure Nothing+ let anyInteresting = List.any (Maybe.isJust . isInteresting) lArgs+ if anyInteresting then Just e else Nothing else- pure Nothing+ Nothing where- interestingPrims =- [("Clash.Sized.Internal.BitVector.*#",tailNonPow2)- ,("Clash.Sized.Internal.BitVector.times#",tailNonPow2)- ,("Clash.Sized.Internal.BitVector.quot#",lastNotPow2)- ,("Clash.Sized.Internal.BitVector.rem#",lastNotPow2)- ,("Clash.Sized.Internal.Index.*#",tailNonPow2)- ,("Clash.Sized.Internal.Index.quot#",lastNotPow2)- ,("Clash.Sized.Internal.Index.rem#",lastNotPow2)- ,("Clash.Sized.Internal.Signed.*#",tailNonPow2)- ,("Clash.Sized.Internal.Signed.times#",tailNonPow2)- ,("Clash.Sized.Internal.Signed.rem#",lastNotPow2)- ,("Clash.Sized.Internal.Signed.quot#",lastNotPow2)- ,("Clash.Sized.Internal.Signed.div#",lastNotPow2)- ,("Clash.Sized.Internal.Signed.mod#",lastNotPow2)- ,("Clash.Sized.Internal.Unsigned.*#",tailNonPow2)- ,("Clash.Sized.Internal.Unsigned.times#",tailNonPow2)- ,("Clash.Sized.Internal.Unsigned.quot#",lastNotPow2)- ,("Clash.Sized.Internal.Unsigned.rem#",lastNotPow2)- ,("GHC.Base.quotInt",lastNotPow2)- ,("GHC.Base.remInt",lastNotPow2)- ,("GHC.Base.divInt",lastNotPow2)- ,("GHC.Base.modInt",lastNotPow2)- ,("GHC.Classes.divInt#",lastNotPow2)- ,("GHC.Classes.modInt#",lastNotPow2)+ isInteresting = (\(x, y, z) -> interestingToLift inScope eval x y z) . collectArgsTicks+ interestingPrims = map (first fromTHName)+ [('(Clash.Sized.Internal.BitVector.*#),bothNotPow2)+ ,('Clash.Sized.Internal.BitVector.times#,bothNotPow2)+ ,('Clash.Sized.Internal.BitVector.quot#,lastNotPow2)+ ,('Clash.Sized.Internal.BitVector.rem#,lastNotPow2)+ ,('(Clash.Sized.Internal.Index.*#),bothNotPow2)+ ,('Clash.Sized.Internal.Index.times#,bothNotPow2)+ ,('Clash.Sized.Internal.Index.quot#,lastNotPow2)+ ,('Clash.Sized.Internal.Index.rem#,lastNotPow2)+ ,('(Clash.Sized.Internal.Signed.*#),bothNotPow2)+ ,('Clash.Sized.Internal.Signed.times#,bothNotPow2)+ ,('Clash.Sized.Internal.Signed.rem#,lastNotPow2)+ ,('Clash.Sized.Internal.Signed.quot#,lastNotPow2)+ ,('Clash.Sized.Internal.Signed.div#,lastNotPow2)+ ,('Clash.Sized.Internal.Signed.mod#,lastNotPow2)+ ,('(Clash.Sized.Internal.Unsigned.*#),bothNotPow2)+ ,('Clash.Sized.Internal.Unsigned.times#,bothNotPow2)+ ,('Clash.Sized.Internal.Unsigned.quot#,lastNotPow2)+ ,('Clash.Sized.Internal.Unsigned.rem#,lastNotPow2)+ ,('GHC.Base.quotInt,lastNotPow2)+ ,('GHC.Base.remInt,lastNotPow2)+ ,('GHC.Base.divInt,lastNotPow2)+ ,('GHC.Base.modInt,lastNotPow2)+ ,('GHC.Classes.divInt#,lastNotPow2)+ ,('GHC.Classes.modInt#,lastNotPow2) #if MIN_VERSION_base(4,15,0)- ,("GHC.Num.Integer.integerMul",allNonPow2)- ,("GHC.Num.Integer.integerDiv",lastNotPow2)- ,("GHC.Num.Integer.integerMod",lastNotPow2)- ,("GHC.Num.Integer.integerQuot",lastNotPow2)- ,("GHC.Num.Integer.integerRem",lastNotPow2)+ ,('GHC.Num.Integer.integerMul,bothNotPow2)+ ,('GHC.Num.Integer.integerDiv,lastNotPow2)+ ,('GHC.Num.Integer.integerMod,lastNotPow2)+ ,('GHC.Num.Integer.integerQuot,lastNotPow2)+ ,('GHC.Num.Integer.integerRem,lastNotPow2) #else- ,("GHC.Integer.Type.timesInteger",allNonPow2)- ,("GHC.Integer.Type.divInteger",lastNotPow2)- ,("GHC.Integer.Type.modInteger",lastNotPow2)- ,("GHC.Integer.Type.quotInteger",lastNotPow2)- ,("GHC.Integer.Type.remInteger",lastNotPow2)+ ,('GHC.Integer.Type.timesInteger,bothNotPow2)+ ,('GHC.Integer.Type.divInteger,lastNotPow2)+ ,('GHC.Integer.Type.modInteger,lastNotPow2)+ ,('GHC.Integer.Type.quotInteger,lastNotPow2)+ ,('GHC.Integer.Type.remInteger,lastNotPow2) #endif- ,("GHC.Prim.*#",allNonPow2)- ,("GHC.Prim.quotInt#",lastNotPow2)- ,("GHC.Prim.remInt#",lastNotPow2)+ ,('(GHC.Prim.*#),bothNotPow2)+ ,('GHC.Prim.quotInt#,lastNotPow2)+ ,('GHC.Prim.remInt#,lastNotPow2) ] lArgs = Either.lefts args - allNonPow2 = all (not . termIsPow2) lArgs- tailNonPow2 = case lArgs of- [] -> True- _ -> all (not . termIsPow2) (drop 1 lArgs) lastNotPow2 = case lArgs of [] -> True _ -> not (termIsPow2 (last lArgs))+ -- | This only looks at the last two arguments, skipping over any constraints if they exist+ bothNotPow2 = go lArgs+ where+ go xs = case xs of+ [] -> True+ [a] -> not (termIsPow2 a)+ [a,b] -> not (termIsPow2 a) && not (termIsPow2 b)+ (_:rest) -> go rest termIsPow2 e' = case eval e' of Literal (IntegerLiteral n) -> isPow2 n a -> case collectArgs a of- (Prim p,[Right _,Left _,Left (Literal (IntegerLiteral n))])- | isFromInteger (primName p) -> isPow2 n+ (Prim p,[Right _,Left _, Left (Literal (IntegerLiteral n))])+ | isFromInt (primName p) -> isPow2 n (Prim p,[Right _,Left _,Left _,Left (Literal (IntegerLiteral n))])- | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> isPow2 n- (Prim p,[Right _, Left _,Left (Literal (IntegerLiteral n))])- | primName p == "Clash.Sized.Internal.BitVector.fromInteger##" -> isPow2 n-+ | primName p == fromTHName 'Clash.Sized.Internal.BitVector.fromInteger# -> isPow2 n _ -> False - isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x-- isFromInteger x = x `elem` ["Clash.Sized.Internal.BitVector.fromInteger#"- ,"Clash.Sized.Integer.Index.fromInteger"- ,"Clash.Sized.Internal.Signed.fromInteger#"- ,"Clash.Sized.Internal.Unsigned.fromInteger#"- ]+ -- This used to contain (x /= 0), but multiplying by zero is free+ isPow2 x = (x .&. (complement x + 1)) == x isHOTy t = case splitFunForallTy t of (args',_) -> any isPolyFunTy (Either.rights args') -interestingToLift _ _ _ _ _ = pure Nothing+interestingToLift _ _ _ _ _ = Nothing++fromTHName :: TH.Name -> Text.Text+fromTHName = Text.pack . show
src/Clash/Normalize/Transformations/Inline.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc.,- 2021-2022, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -14,6 +14,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}@@ -48,7 +49,7 @@ import GHC.BasicTypes.Extra (isNoInline) import qualified Clash.Explicit.SimIO as SimIO-import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV))+import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV), xToBV) import Clash.Annotations.Primitive (extractPrim) import Clash.Core.DataCon (DataCon(..))@@ -119,7 +120,14 @@ True -> return (i `notElemFreeVars` e) _ -> do tcm <- Lens.view tcCache- case isWorkFreeIsh tcm e of+ (fn,_) <- Lens.use curFun+ -- Don't inline things that perform work, it increases the circuit size.+ --+ -- Also don't inline globally recursive calls, it prevents the+ -- recToLetRec transformation from transforming global recursion to+ -- local recursion.+ -- See https://github.com/clash-lang/clash-compiler/issues/2839+ case isWorkFreeIsh tcm e && not (e == Var fn) of True -> Lens.view inlineConstantLimit >>= \case 0 -> return True n -> return (termSize e <= n)@@ -438,7 +446,8 @@ 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+ isNoopApp x (Prim PrimInfo{primName},args)+ | primName == Text.showt 'BV.xToBV = 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
src/Clash/Normalize/Transformations/MultiPrim.hs view
@@ -58,7 +58,7 @@ -- will be rewritten to: -- -- @--- \(x :: a) ->+-- \\(x :: a) -> -- let -- r = prim @a @b @c x r0 r1 -- With 'Clash.Core.Term.MultiPrim' -- r0 = c$multiPrimSelect r0 r@@ -98,10 +98,11 @@ internalNm prefix n = mkUnsafeInternalName (prefix <> showt n) n internalId prefix typ n = mkLocalId typ (internalNm prefix n) - nTermArgs = length (Either.rights pArgs)+ nTermArgs = fromIntegral (length (Either.rights pArgs))+ nResTypes = fromIntegral (length resTypes) argIds = zipWith (internalId "a") (Either.rights pArgs) [1..nTermArgs]- resIds = zipWith (internalId "r") resTypes [nTermArgs+1..nTermArgs+length resTypes]- resId = mkLocalId pResTy (mkUnsafeInternalName "r" (nTermArgs+length resTypes+1))+ resIds = zipWith (internalId "r") resTypes [nTermArgs+1..nTermArgs+nResTypes]+ resId = mkLocalId pResTy (mkUnsafeInternalName "r" (nTermArgs+nResTypes+1)) (pArgs, pResTy) = splitFunForallTy primType MultiPrimInfo{mpi_resultDc=tupTc, mpi_resultTypes=resTypes} =
src/Clash/Normalize/Transformations/Specialize.hs view
@@ -96,6 +96,7 @@ ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory) import Clash.Normalize.Util (constantSpecInfo, csrFoundConstant, csrNewBindings, csrNewTerm)+import Clash.Unique (Unique) import Clash.Util (ClashException(..)) -- | Propagate arguments of application inwards; except for 'Lam' where the@@ -141,7 +142,7 @@ -- Imagine -- -- @--- (\x -> e) u+-- (\\x -> e) u -- @ -- -- where @u@ has a free variable named @x@, rewriting this to:@@ -438,7 +439,7 @@ else do let existingNames = collectBndrsMinusApps bodyTm newNames = [ mkUnsafeInternalName ("pTS" `Text.append` Text.pack (show n)) n- | n <- [(0::Int)..]+ | n <- [(0::Unique)..] ] -- Make new binders for existing arguments (boundArgs,argVars) <- fmap (unzip . map (either (Left &&& Left . Var) (Right &&& Right . VarTy))) $
src/Clash/Normalize/Util.hs view
@@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente,- 2021-2022, QBayLogic B.V.+ 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -48,10 +48,8 @@ #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqTyConKey)-import GHC.Types.Unique (getKey) #else import PrelNames (eqTyConKey)-import Unique (getKey) #endif import Clash.Annotations.Primitive (extractPrim)@@ -450,7 +448,7 @@ go args changed (TyLam tv e) = go (Right tv : args) changed e go args changed (Lam v e) | TyConApp (nameUniq -> tcUniq) (tvFirst -> Just (tv, ty)) <- tyView (coreTypeOf v)- , tcUniq == getKey eqTyConKey+ , tcUniq == fromGhcUnique eqTyConKey , Right tv `elem` args = let tvs = rights args@@ -479,7 +477,7 @@ = go (Left tv:argsOut) changed ty go argsOut changed (tyView -> FunTy arg tyRes) | Just (tc,tcArgs) <- splitTyConAppM arg- , nameUniq tc == getKey eqTyConKey+ , nameUniq tc == fromGhcUnique eqTyConKey , Just (tv,ty) <- tvFirst tcArgs = let argsOut2 = Right arg : (argsOut List.\\ [Left tv])
src/Clash/Primitives/DSL.hs view
@@ -1,6 +1,6 @@ {-| Copyright : (C) 2019, Myrtle Software Ltd.- 2020-2023, QBayLogic B.V.+ 2020-2024, QBayLogic B.V. 2021, Myrtle.ai 2022-2023, Google Inc License : BSD2 (see the file LICENSE)@@ -127,7 +127,8 @@ import Clash.Netlist.Util import Clash.Util (clogBase) import qualified Data.String.Interpolate as I-import Language.Haskell.TH (Name)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH import Prelude -- | Options for 'blackBoxHaskell' function. Use 'def' from package@@ -164,9 +165,9 @@ -- -- @[1,2]@ would mean this blackbox __ignores__ its second and third argument. blackBoxHaskell- :: Name+ :: TH.Name -- ^ blackbox name- -> Name+ -> TH.Name -- ^ template function name -> BlackBoxHaskellOpts -- ^ Options, see data structure for more information@@ -649,14 +650,32 @@ -- | Create an n-tuple of 'TExpr' tuple :: HasCallStack => [TExpr] -> TExpr-tuple [] = error $ "nTuple: Cannot create empty tuple"+tuple [] = error $ "tuple: Cannot create empty tuple" tuple [_] = -- If we don't put this in: tuple . untuple /= id- error $ "nTuple: Cannot create 1-tuple"+ error $ "tuple: Cannot create 1-tuple" tuple els = constructProduct tupTy els where+#if MIN_VERSION_base(4,19,0)+ tupTy = Product (tupModule <> ".Tuple" <> showt (length els)) Nothing (map ety els)+ tupModule =+ $(+ let tupNm = ''(,)+ in case (TH.nameModule tupNm, TH.nameBase tupNm) of+ (Just modNm, "Tuple2") -> TH.lift modNm :: TH.ExpQ+ _ -> error $ "tuple: (,) has an unexpected name: " <> show tupNm+ )+#else commas = Text.replicate (length els - 1) ","- tupTy = Product ("GHC.Tuple.(" <> commas <> ")") Nothing (map ety els)+ tupTy = Product (tupModule <> ".(" <> commas <> ")") Nothing (map ety els)+ tupModule =+ $(+ let tupNm = ''(,)+ in case (TH.nameModule tupNm, TH.nameBase tupNm) of+ (Just modNm, "(,)") -> TH.lift modNm :: TH.ExpQ+ _ -> error $ "tuple: (,) has an unexpected name: " <> show tupNm+ )+#endif -- | Try to get the literal string value of an expression. getStr :: TExpr -> Maybe String@@ -842,14 +861,12 @@ -- -- A typical result is that a ----- @--- component fifo port--- ( rst : in std_logic--- ...--- ; full : out std_logic--- ; empty : out std_logic );--- end component;--- @+-- > component fifo port+-- > ( rst : in std_logic+-- > ...+-- > ; full : out std_logic+-- > ; empty : out std_logic );+-- > end component; -- -- declaration would be added in the appropriate place. compInBlock@@ -1068,9 +1085,7 @@ -- | Creates a BV that produces the following vhdl: ----- @--- (0 to n => ARG)--- @+-- > (0 to n => ARG) -- -- TODO: Implement for (System)Verilog pureToBV@@ -1090,9 +1105,7 @@ -- | Creates a BV that produces the following vhdl: ----- @--- std_logic_vector(resize(ARG, n))--- @+-- > std_logic_vector(resize(ARG, n)) -- -- TODO: Implement for (System)Verilog pureToBVResized
src/Clash/Rewrite/Types.hs view
@@ -21,7 +21,6 @@ module Clash.Rewrite.Types where -import Control.Concurrent.Supply (Supply, freshId) import Control.DeepSeq (NFData) import Control.Lens (Lens', use, (.=)) import qualified Control.Lens as Lens@@ -57,6 +56,7 @@ import Clash.Primitives.Types (CompiledPrimMap) import Clash.Rewrite.WorkFree (isWorkFree) import Clash.Util+import Clash.Util.Supply (Supply, freshId) import Clash.Annotations.BitRepresentation.Internal (CustomReprs)
src/Clash/Rewrite/Util.hs view
@@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc.,- 2021-2022, QBayLogic B.V.+ 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -24,7 +24,6 @@ , module Clash.Rewrite.WorkFree ) where -import Control.Concurrent.Supply (splitSupply) import Control.DeepSeq import Control.Exception (throw) import Control.Lens ((%=), (+=), (^.))@@ -77,7 +76,7 @@ import Clash.Core.Var (Id, IdScope (..), TyVar, Var (..), mkGlobalId, mkLocalId, mkTyVar) import Clash.Core.VarEnv- (InScopeSet, extendInScopeSet, extendInScopeSetList, mkInScopeSet,+ (InScopeSet, extendInScopeSet, extendInScopeSetList, mkInScopeSet, notElemInScopeSet, uniqAway, uniqAway', mapVarEnv, eltsVarEnv, unitVarSet, emptyVarEnv, mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv, elemVarSet, differenceVarEnv)@@ -95,6 +94,7 @@ import Clash.Util import Clash.Util.Eq (fastEqBy) import qualified Clash.Util.Interpolate as I+import Clash.Util.Supply (splitSupply) -- | Lift an action working in the '_extra' state to the 'RewriteMonad' zoomExtra :: State.State extra a -> RewriteMonad extra a@@ -173,12 +173,13 @@ return () if isDebugging opts- then applyDebug s expr0 hasChanged expr1+ then applyDebug ctx s expr0 hasChanged expr1 else return expr1 {-# INLINE apply #-} applyDebug- :: String+ :: TransformContext+ -> String -- ^ Name of the transformation -> Term -- ^ Original expression@@ -187,7 +188,7 @@ -> Term -- ^ New expression -> RewriteMonad extra Term-applyDebug name exprOld hasChanged exprNew = do+applyDebug ctx name exprOld hasChanged exprNew = do nTrans <- Lens.use transformCounter opts <- Lens.view debugOpts @@ -212,9 +213,14 @@ let beforeTy = inferCoreTypeOf tcm exprOld beforeFV = Lens.setOf freeLocalVars exprOld afterTy = inferCoreTypeOf tcm exprNew- afterFV = Lens.setOf freeLocalVars exprNew+ afterFV = filterFVs (Lens.setOf freeLocalVars exprNew) newFV = not (afterFV `Set.isSubsetOf` beforeFV) accidentalShadows = findAccidentialShadows exprNew+ -- see NOTE [Filter free variables]+ allowNewFVsFromCtx = name == "caseCon"+ filterFVs | allowNewFVsFromCtx = Set.filter notInCtx+ | otherwise = id+ notInCtx v = notElemInScopeSet v (tfInScope ctx) Monad.when newFV $ error ( concat [ $(curLoc)@@ -265,6 +271,17 @@ where before = showPpr exprOld after = showPpr exprNew++-- NOTE [Filter free variables]+-- Since [Give evaluator acces to inscope let-bindings #2571](https://github.com/clash-lang/clash-compiler/pull/2571)+-- the evaluator can rewrite expressions using let bindings from the 'TransformContext',+-- these bindings may reference other things bound in the context which weren't+-- in the expression before, and in doing so introduces new free variables and+-- fails this check for new free variables.+-- To prevent this we filter out all variables from bound in the context.+-- But only during a caseCon transformation, to not weaken this check unnecessarily.++ -- | Perform a transformation on a Term runRewrite
src/Clash/Rewrite/WorkFree.hs view
@@ -155,7 +155,18 @@ if isClockOrReset tcm eTy || isEnable tcm eTy then case collectArgs e of (Prim p,_) -> Just (primName p == Text.showt 'removedArg)- (Var _, []) -> Just True+ -- Only local variables with a clock type are work-free. When it is a global+ -- variable, it is probably backed by a clock generator, which is definitely+ -- not work-free.+ --+ -- Inlining let-bindings referencing a global variable with a clock type+ -- can sometimes lead to the post-normalization flattening stage to generate+ -- code that violates the invariants of the netlist generation stage.+ -- Especially when this global binder is defined recursively such as when+ -- using `tbClockGen`.+ -- This then ultimately leads to bad verilog names being generated as+ -- reported in: https://github.com/clash-lang/clash-compiler/issues/2845+ (Var v, []) -> Just (isLocalId v) (Data _, [_dom, Left (stripTicks -> Data _)]) -> Just True -- For Enable True/False (Literal _,_) -> Just True _ -> Just False
src/Clash/Unique.hs view
@@ -1,12 +1,60 @@+{-|+ Copyright : (C) 2024, QBayLogic B.V.+ License : BSD2 (see the file LICENSE)+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeSynonymInstances #-} module Clash.Unique ( Unique+ , pattern Unique#+ , Unique# , Uniquable (..)+ , fromGhcUnique ) where +import Data.Word (Word64)+#if MIN_VERSION_ghc(9,8,4)+import GHC.Word (Word64(W64#))+import GHC.Exts (Word64#)+#else+import GHC.Int (Int(I#))+import GHC.Exts (Int#)+#endif+#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Types.Unique as GHC+#else+import qualified Unique as GHC+#endif++#if MIN_VERSION_ghc(9,8,4)+type Unique = Word64+type Unique# = Word64#++pattern Unique#+ :: Unique#+ -- ^ Type of signal+ -> Unique+pattern Unique# u <- W64# u+ where+ Unique# u = W64# u+#else type Unique = Int+type Unique# = Int# +pattern Unique#+ :: Unique#+ -- ^ Type of signal+ -> Unique+pattern Unique# u <- I# u+ where+ Unique# u = I# u+#endif+ class Uniquable a where getUnique :: a -> Unique setUnique :: a -> Unique -> a@@ -14,3 +62,12 @@ instance Uniquable Unique where getUnique = id setUnique = flip const++#if !MIN_VERSION_ghc(9,8,4)+instance Uniquable Word64 where+ getUnique = fromIntegral+ setUnique _ = fromIntegral+#endif++fromGhcUnique :: GHC.Unique -> Unique+fromGhcUnique = GHC.getKey
src/Clash/Util.hs view
@@ -153,9 +153,9 @@ -- | A class that can generate unique numbers class Monad m => MonadUnique m where -- | Get a new unique- getUniqueM :: m Int+ getUniqueM :: m Unique -instance Monad m => MonadUnique (StateT Int m) where+instance Monad m => MonadUnique (StateT Unique m) where getUniqueM = do supply <- State.get State.modify (+1)
src/Clash/Util/Graph.hs view
@@ -6,6 +6,8 @@ Collection of utilities -} +{-# LANGUAGE CPP #-}+ module Clash.Util.Graph ( topSort , reverseTopSort@@ -14,15 +16,28 @@ import Data.Tuple (swap) import Data.Foldable (foldlM)+#if MIN_VERSION_ghc(9,8,4)+import qualified GHC.Data.Word64Map.Strict as IntMap+import qualified GHC.Data.Word64Set as IntSet+#else+import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap+import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet+#endif import Clash.Core.Var (Id) import Clash.Core.Term (Term) import qualified Clash.Data.UniqMap as UniqMap import Clash.Driver.Types (BindingMap, Binding (bindingTerm)) import Clash.Normalize.Util (callGraph)+import Clash.Unique (Unique) +#if MIN_VERSION_ghc(9,8,4)+type IntMap = IntMap.Word64Map+type IntSet = IntSet.Word64Set+#endif+ data Marker = Temporary | Permanent@@ -32,17 +47,17 @@ headSafe (a:_) = Just a topSortVisit'- :: IntMap.IntMap [Int]+ :: IntMap [Unique] -- ^ Edges- -> IntSet.IntSet+ -> IntSet -- ^ Unmarked nodes- -> IntMap.IntMap Marker+ -> IntMap Marker -- ^ Marked nodes- -> [Int]+ -> [Unique] -- ^ Sorted so far- -> Int+ -> Unique -- ^ Node to visit- -> Either String (IntSet.IntSet, IntMap.IntMap Marker, [Int])+ -> Either String (IntSet, IntMap Marker, [Unique]) topSortVisit' edges unmarked marked sorted node = case IntMap.lookup node marked of Just Permanent -> Right (unmarked, marked, sorted)@@ -60,17 +75,17 @@ topSortVisit' edges unmarked' marked' sorted' node' topSortVisit- :: IntMap.IntMap [Int]+ :: IntMap [Unique] -- ^ Edges- -> IntSet.IntSet+ -> IntSet -- ^ Unmarked nodes- -> IntMap.IntMap Marker+ -> IntMap Marker -- ^ Marked nodes- -> [Int]+ -> [Unique] -- ^ Sorted so far- -> Int+ -> Unique -- ^ Node to visit- -> Either String (IntSet.IntSet, IntMap.IntMap Marker, [Int])+ -> Either String (IntSet, IntMap Marker, [Unique]) topSortVisit edges unmarked marked sorted node = do (unmarked', marked', sorted') <- topSortVisit' edges unmarked marked sorted node@@ -83,9 +98,9 @@ -- errors if edges mention nodes not mentioned in the node list or if the -- given graph contains cycles. topSort- :: [(Int, a)]+ :: [(Unique, a)] -- ^ Nodes- -> [(Int, Int)]+ -> [(Unique, Unique)] -- ^ Edges -> Either String [a] -- ^ Error message or topologically sorted nodes@@ -128,9 +143,9 @@ -- Likewise, this function promises __one__ of those lists in reverse, but not -- necessarily the reverse of topSort itself. reverseTopSort- :: [(Int, a)]+ :: [(Unique, a)] -- ^ Nodes- -> [(Int, Int)]+ -> [(Unique, Unique)] -- ^ Edges -> Either String [a] -- ^ Reversely, topologically sorted nodes
+ src/Clash/Util/Supply.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE MagicHash, UnboxedTuples, CPP, PatternSynonyms #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+{-# OPTIONS_GHC -fno-full-laziness #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Clash.Util.Supply+-- Copyright : (C) 2011-2013 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- A fast unique identifier supply with local pooling and replay+-- support.+--+-- One often has a desire to generate a bunch of integer identifiers within+-- a single process that are unique within that process. You could use+-- UUIDs, but they can be expensive to generate; you don't want to have+-- your threads contending for a single external counter if the identifier+-- is not going to be used outside the process.+--+-- @concurrent-supply@ builds a tree-like structure which can be split; you+-- can make smaller unique supplies and then you allocate from your supplies+-- locally. Internally it pulls from a unique supply one block at a time as+-- you walk into parts of the tree that haven't been explored.+--+----------------------------------------------------------------------------+module Clash.Util.Supply+ ( Supply+ -- * Variables+ , newSupply+ , freshId+ , splitSupply+ -- * Unboxed API+ , freshId#+ , splitSupply#+ ) where++import Data.Hashable+import Data.IORef+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+import Data.Monoid+#endif+import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)++import Clash.Unique (Unique, Unique#, pattern Unique#)++infixr 5 :-+data Stream a = a :- Stream a++instance Functor Stream where+ fmap f (a :- as) = f a :- fmap f as++extract :: Stream a -> a+extract (a :- _) = a++units :: Stream ()+units = () :- units+{-# NOINLINE units #-}++data Block = Block Unique !(Stream Block)++instance Eq Block where+ Block a (Block b _ :- _) == Block c (Block d _ :- _) = a == c && b == d++instance Ord Block where+ Block a (Block b _ :- _) `compare` Block c (Block d _ :- _) = compare a c `mappend` compare b d++instance Show Block where+ showsPrec d (Block a (Block b _ :- _)) = showParen (d >= 10) $+ showString "Block " . showsPrec 10 a . showString " (Block " . showsPrec 10 b . showString " ... :- ...)"++instance Hashable Block where+ hashWithSalt s (Block a (Block b _ :- _)) = s `hashWithSalt` a `hashWithSalt` b++blockSize :: Unique+blockSize = 1024+{-# INLINE blockSize #-}++-- Minimum size to be worth splitting a supply rather than just CAS'ing twice to avoid multiple subsequent biased splits+minSplitSupplySize :: Unique+minSplitSupplySize = 32 -- based on sqrt blockSize+{-# INLINE minSplitSupplySize #-}++blockCounter :: IORef Unique+blockCounter = unsafePerformIO (newIORef 0)+{-# NOINLINE blockCounter #-}++modifyBlock :: a -> IO Unique+modifyBlock _ = atomicModifyIORef blockCounter $ \ i -> let i' = i + blockSize in i' `seq` (i', i)+{-# NOINLINE modifyBlock #-}++gen :: a -> Block+gen x = Block (unsafeDupablePerformIO (modifyBlock x)) (gen <$> units)+{-# NOINLINE gen #-}++newBlock :: IO Block+newBlock = return $! gen ()+{-# NOINLINE newBlock #-}++splitBlock# :: Block -> (# Block, Block #)+splitBlock# (Block i (x :- xs)) = (# x, Block i xs #)+{-# INLINE splitBlock# #-}++-- | A user managed globally unique variable supply.+data Supply = Supply {-# UNPACK #-} !Unique {-# UNPACK #-} !Unique Block+ deriving (Eq,Ord,Show)++instance Hashable Supply where+ hashWithSalt s (Supply i j b) = s `hashWithSalt` i `hashWithSalt` j `hashWithSalt` b++blockSupply :: Block -> Supply+blockSupply (Block i bs) = Supply i (i + blockSize - 1) (extract bs)+{-# INLINE blockSupply #-}++-- | Grab a new supply. Any two supplies obtained with newSupply are guaranteed to return+-- disjoint sets of identifiers. Replaying the same sequence of operations on the same+-- Supply will yield the same results.+newSupply :: IO Supply+newSupply = blockSupply <$> newBlock+{-# INLINE newSupply #-}++-- | Obtain a fresh Id from a Supply.+freshId :: Supply -> (Unique, Supply)+freshId s = case freshId# s of+ (# i, s' #) -> (Unique# i, s')+{-# INLINE freshId #-}++-- | Split a supply into two supplies that will return disjoint identifiers+splitSupply :: Supply -> (Supply, Supply)+splitSupply s = case splitSupply# s of+ (# l, r #) -> (l, r)+{-# INLINE splitSupply #-}++-- | An unboxed version of freshId+freshId# :: Supply -> (# Unique#, Supply #)+freshId# (Supply i@(Unique# i#) j b)+ | i /= j = (# i#, Supply (i + 1) j b #)+ | otherwise = (# i#, blockSupply b #)+{-# INLINE freshId# #-}++-- | An unboxed version of splitSupply+splitSupply# :: Supply -> (# Supply, Supply #)+splitSupply# (Supply i k b) = case splitBlock# b of+ (# bl, br #)+ | k - i >= minSplitSupplySize+ , j <- i + div (k - i) 2 ->+ (# Supply i j bl, Supply (j + 1) k br #)+ | Block x (l :- r :- _) <- bl+ , y <- x + div blockSize 2+ , z <- x + blockSize - 1 ->+ (# Supply x (y - 1) l, Supply y z r #)+{-# INLINE splitSupply# #-}
src/Data/Aeson/Extra.hs view
@@ -1,5 +1,6 @@ {-| Copyright : (C) 2015-2016, University of Twente+ 2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -}@@ -23,7 +24,12 @@ import Data.Text.Encoding.Error (UnicodeException(..)) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))+#if MIN_VERSION_base(4,20,0)+import qualified Data.List.NonEmpty as NE hiding (unzip)+import qualified Data.Functor as NE+#else import qualified Data.List.NonEmpty as NE+#endif import Data.Tuple.Extra (second, first) import Data.Aeson (FromJSON, Result (..), fromJSON) import Data.Aeson.Parser (json)
src/Data/List/Extra.hs view
@@ -4,6 +4,7 @@ module Data.List.Extra ( partitionM , mapAccumLM+ , mapAccumRM , iterateNM , (<:>) , indexMaybe@@ -45,6 +46,19 @@ (acc',y) <- f acc x (acc'',ys) <- mapAccumLM f acc' xs return (acc'',y:ys)++-- | Monadic version of 'Data.List.mapAccumR'+mapAccumRM+ :: Monad m+ => (acc -> x -> m (acc,y))+ -> acc+ -> [x]+ -> m (acc,[y])+mapAccumRM _ acc [] = return (acc,[])+mapAccumRM f acc (x:xs) = do+ (acc1,ys) <- mapAccumRM f acc xs+ (acc2,y) <- f acc1 x+ return (acc2,y:ys) -- | Monadic version of 'iterate'. A carbon copy ('iterateM') would not -- terminate, hence the first argument.
tests/Clash/Tests/Core/Subst.hs view
@@ -18,6 +18,7 @@ import Clash.Core.Subst import Clash.Core.VarEnv import Clash.Core.Var (IdScope(..), Var(..))+import Clash.Unique (Unique) fakeName :: Name a fakeName =@@ -28,7 +29,7 @@ , nameLoc=noSrcSpan } -unique :: Int+unique :: Unique unique = 20 termVar :: Var Term
tests/Test/Clash/Rewrite.hs view
@@ -27,9 +27,10 @@ import Clash.Rewrite.Util (runRewrite) import Clash.Normalize.Types import qualified Clash.Util.Interpolate as I+import Clash.Util.Supply (newSupply)+import Clash.Unique (Unique) import Control.Applicative ((<|>))-import Control.Concurrent.Supply (newSupply) import Data.Default import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.Parser (parseExp, fromParseResult)@@ -46,9 +47,9 @@ import qualified Data.IntMap as IntMap import qualified Data.Text as Text -type TypeMap = HashMap.HashMap Int C.Type+type TypeMap = HashMap.HashMap Unique C.Type -lookupTM :: Int -> TypeMap -> C.Type+lookupTM :: Unique -> TypeMap -> C.Type lookupTM u tm = case HashMap.lookup u tm of Just t -> t Nothing ->@@ -217,7 +218,7 @@ e -> error ("parseOtherDecl: " <> show e) - parseTypeDecl :: Decl l -> [(Int, C.Type)]+ parseTypeDecl :: Decl l -> [(Unique, C.Type)] parseTypeDecl (TypeSig _ nms t) = map (\nm -> (C.nameUniq (parseName nm), parseType t)) nms parseTypeDecl _ = error "impossible"
tools/v16-upgrade-primitives.hs view
@@ -9,8 +9,9 @@ #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as Aeson-import Data.ByteString.Lazy.Search (replace) import Data.String (IsString)+import qualified Data.Text.Lazy as LazyText+import qualified Data.Text.Lazy.Encoding as LazyText #endif import qualified Data.Aeson.Extra as AesonExtra@@ -89,9 +90,10 @@ Just val -> Aeson.insert kNew val (Aeson.delete kOld obj) removeTempKey :: ByteString -> ByteString-removeTempKey inp = foldl go inp keySortingRenames+removeTempKey inp =+ LazyText.encodeUtf8 (foldl go (LazyText.decodeUtf8 inp) keySortingRenames) where- go bs (orig,temp) = replace (ByteString.toStrict temp) orig bs+ go txt (orig,temp) = LazyText.replace temp orig txt #else -- < aeson-2.0 stores keys in HashMaps, whose order we can't possibly predict. removeTempKey :: ByteString -> ByteString