clash-lib 1.10.0 → 1.10.1

raw patch · 28 files changed

+665/−237 lines, 28 filesdep +ghcidep −data-binary-ieee754dep ~aesondep ~clash-preludedep ~string-interpolatePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghci

Dependencies removed: data-binary-ieee754

Dependency ranges changed: aeson, clash-prelude, string-interpolate, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +67/−0
• clash-lib.cabal +6/−6
• prims/vhdl/GHC_Num_Integer.primitives.yaml +2/−2
• src/Clash/Annotations/TopEntity/Extra.hs +10/−7
• src/Clash/Backend/VHDL.hs +37/−11
• src/Clash/Core/EqSolver.hs +10/−1
• src/Clash/Core/Literal.hs +2/−2
• src/Clash/Core/Pretty.hs +3/−3
• src/Clash/Core/Type.hs +7/−0
• src/Clash/Core/Util.hs +1/−1
• src/Clash/Driver.hs +22/−6
• src/Clash/Driver/Manifest.hs +77/−13
• src/Clash/Driver/Types.hs +9/−0
• src/Clash/Netlist/BlackBox.hs +54/−24
• src/Clash/Netlist/BlackBox/Util.hs +4/−4
• src/Clash/Netlist/Util.hs +90/−29
• src/Clash/Normalize.hs +90/−67
• src/Clash/Normalize/PrimitiveReductions.hs +31/−25
• src/Clash/Normalize/Strategy.hs +7/−4
• src/Clash/Normalize/Transformations/ANF.hs +2/−1
• src/Clash/Normalize/Transformations/Case.hs +5/−5
• src/Clash/Normalize/Transformations/Letrec.hs +20/−10
• src/Clash/Rewrite/Combinators.hs +65/−1
• src/Clash/Rewrite/Types.hs +2/−0
• src/Clash/Rewrite/Util.hs +11/−12
• src/Clash/Util/Interpolate.hs +7/−2
• tests/Clash/Tests/Driver/Manifest.hs +10/−0
• tests/Clash/Tests/Util/Interpolate.hs +14/−1

@@ -1,5 +1,72 @@ # Changelog for the Clash project +## 1.10.1 *Aug 27th, 2026*++Highlights:+ * Very significant performance improvements, further detailed below. We also created a site https://clash-lang.github.io/clash-benchmarks/ where we track performance improvements. These graphs are for the current `master` branch, not for released Clash versions.+ * We have added support for the `checked-literals` package. Numeric literals (e.g., `5` or `3.2`) can now be checked at compile time. That is, you'll get a compile error if the literal does not fit the target type -- even in polymorphic contexts! You can enable the checker by adding the following to your project's Cabal file:++    ```+    library+      [..]++      build-depends:+        [..]+        checked-literals++      ghc-options: -fplugin=CheckedLiterals+    ```++    See https://clash-lang.org/blog/2026-04-07-checked-literals/.++Performance:+* `clash` and `clashi` now use GHC-style RTS defaults through executable `-with-rtsopts` flags instead of linking RTS hooks. The existing unused hooks have been removed. **Existing users should set `-with-rtsopts` to `-K512M -H -I5 -T` if they use their own Clash executable. These flags has been shown to give a ~25% compilation speed up in larger designs.** If you used a Clash starter project to initialize your design, you should change:++    ```haskell+    executable clash+      [..]+    ```++    To:++    ```haskell+    executable clash+      [..]+      ghc-options: "-with-rtsopts=-K512M -H -I5 -T"+    ```++    in the cabal file. See [#3252](https://github.com/clash-lang/clash-compiler/issues/3252).+* Improved normalization performance for repeated top-down rewrite loops by avoiding full root restarts after every successful rewrite. This gives a ~17% performance improvements on larger designs [#3249](https://github.com/clash-lang/clash-compiler/issues/3249).+* Clash now converts GHC Core to its own Clash Core in parallel. For larger projects, this can shave off ~40% of load times. See [#3299](https://github.com/clash-lang/clash-compiler/issues/3299).+* Clash now prunes the binders it collects from top modules when loading from precompiled core. For larger projects, this can shave off 15% of package loading times. See [#3298](https://github.com/clash-lang/clash-compiler/issues/3298).+* `flattenCallTree` now caches intermediate results, reducing Clash normalization by 10% for realistic designs. Fixes #[3246](https://github.com/clash-lang/clash-compiler/issues/3246).++Added:+* `-fclash-debug-manifest-hash`. When enabled, Clash emits a `__debug_hash` object in `clash-manifest.json` listing the SHA256 of each input that feeds into the top-level `hash` (`tops`, `prim_map`, `clash_mod_date`, `call_graph`, `opts`). As the name implies, this should only be used to debug and should not be relied upon by tooling. See [#3280](https://github.com/clash-lang/clash-compiler/pull/3280).+* `SaturatingNum` instances for `Erroring`, `Overflowing`, `Saturating`, `Wrapping`, and `Zeroing`.++Changed:+* Replaced the deprecated `data-binary-ieee754` dependency with `castDoubleToWord64`, `castFloatToWord32`, `castWord32ToFloat`, and `castWord64ToDouble` from `GHC.Float`. See [#3174](https://github.com/clash-lang/clash-compiler/issues/3174).+* `flake.nix` now advertises the [clash-lang Cachix binary cache](https://clash-lang.cachix.org) via `nixConfig.extra-substituters`. Running `nix develop` will prompt you to trust the cache, avoiding having to build Clash from source. See [#3213](https://github.com/clash-lang/clash-compiler/issues/3213).++Fixed:+* Clash no longer crashes for self-recursive global binders in very specific circumstances. See [#3311](https://github.com/clash-lang/clash-compiler/issues/3311).+* Clash no longer crashes upon calling `sequenceA`/`traverse#` on a zero-sized `Vec`. See [#3290](https://github.com/clash-lang/clash-compiler/issues/3290).+* Clash no longer crashes when constant-folding partial primitives in the GHC evaluator. This covers `shiftL`/`shiftR`/`rotateL`/`rotateR` with negative shift amounts on `BitVector`/`Signed`/`Unsigned`, `(^)` with negative exponents, `chr` on out-of-range integers, and `quot`/`rem`/`div`/`mod` by zero on `Int`/`Word`/`Int{8,16,32,64}`/`Word{8,16,32,64}`. Such expressions now fold to `undefined` (rather than crashing the compiler). Fixes [#3234](https://github.com/clash-lang/clash-compiler/issues/3234).+* Clash no longer crashes with `mkVecNil: failed to instantiate Nil DC` when unfolding `traverse#` in very specific circumstances. See [#3291](https://github.com/clash-lang/clash-compiler/issues/3291).+* Clash no longer errors when two `-i` import paths refer to the same directory via different syntactic spellings (e.g. `-isrc -isrc/.`) and a data file lives in that directory. See [#3142](https://github.com/clash-lang/clash-compiler/issues/3142).+* Clash no longer produces an error when using `dataToTag` in combination with custom bit representations. See [#2724](https://github.com/clash-lang/clash-compiler/issues/2724).+* Clash no longer takes exponential time and memory normalizing `foldl`/`scanl`/`splitAt` over a vector when the result keeps the (co-recursively defined) vector spine alive, e.g. `snd (foldl const (z, s) (xs :: Vec n a))`. The evaluator's `zipWith` and `splitAt` reductions now share their arguments instead of duplicating the vector spine on every peel. See [#3308](https://github.com/clash-lang/clash-compiler/issues/3308).+* Clash now recognizes `~` when solving GADT arms. Fixes [#3232](https://github.com/clash-lang/clash-compiler/issues/3232).+* Clash will no longer generate duplicate `attribute` when they're both used for top entity ports and internal signals. See [#3218](https://github.com/clash-lang/clash-compiler/issues/3218). The VHDL backend now also reports a clearer error when a synthesis attribute is declared with conflicting types in the same design.+* Due to HDL standards, when the result of a top entity is read by another binder Clash is forced to introduce an internal indirection signal. Clash no longer attaches the top entity's `Annotate` synthesis attributes to that internal signal, preventing duplicate synthesis attributes in the generated HDL. See [#3224](https://github.com/clash-lang/clash-compiler/issues/3224).+* Errors in `Synthesize` port annotations (e.g. a `PortProduct` on a non-product port) are now reported before a design is normalized, instead of afterwards. This avoids waiting for a potentially long normalization only to get a trivial port error. See [#3305](https://github.com/clash-lang/clash-compiler/issues/3305).+* Run `bindConstantVar` after post-normalization `inlineCleanup`/`caseCon` so constant let-bindings exposed late are inlined before netlist generation [#3041](https://github.com/clash-lang/clash-compiler/issues/3041).+* The VHDL primitives for `integerToNaturalThrow` and `integerToNaturalClamp` no longer contain syntax errors. See [#3315](https://github.com/clash-lang/clash-compiler/pull/3315).+* The internal function `Clash.Util.Interpolate.i` in `clash-lib` no longer inserts an extra blank line after a paragraph that gets reflowed onto multiple lines. See [#2753](https://github.com/clash-lang/clash-compiler/issues/2753).+* `deriveAutoReg` no longer fails on GHC versions where `KnownNat` lives in `GHC.Internal.TypeNats` rather than `GHC.TypeNats`. See [#3100](https://github.com/clash-lang/clash-compiler/issues/3100).+* `makeTopEntity` now accounts for unary product types. See [#3066](https://github.com/clash-lang/clash-compiler/issues/3066).+ ## 1.10.0 *Apr 23rd, 2026*  Release highlight:

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-lib-Version:              1.10.0+Version:              1.10.1 Synopsis:             Clash: a functional hardware description language - As a library Description:   Clash is a functional hardware description language that borrows both its@@ -144,7 +144,7 @@                       RecordWildCards                       TemplateHaskell -  Build-depends:      aeson                   >= 2.0.0.0  && < 2.3,+  Build-depends:      aeson                   >= 2.0.0.0  && < 2.4,                       attoparsec-aeson        >= 2.1      && < 2.3,                       aeson-pretty            >= 0.8      && < 0.9,                       ansi-terminal           >= 0.8.0.0  && < 1.2,@@ -155,10 +155,9 @@                       base16-bytestring       >= 0.1.1    && < 1.1,                       binary                  >= 0.8.5    && < 0.11,                       bytestring              >= 0.10.0.2 && < 0.13,-                      clash-prelude           == 1.10.0,+                      clash-prelude           == 1.10.1,                       containers              >= 0.6.7    && < 0.9,                       cryptohash-sha256       >= 0.11     && < 0.12,-                      data-binary-ieee754     >= 0.4.4    && < 0.6,                       data-default            >= 0.7      && < 0.9,                       deepseq                 >= 1.3.0.2  && < 1.6,                       dlist                   >= 0.8      && < 1.1,@@ -171,6 +170,7 @@                       ghc-boot-th,                       ghc-prim,                       ghc-bignum              >=1.0       && <1.4,+                      ghci                    >= 9.6.0    && < 9.13,                       hashable                >= 1.4.1.0  && < 1.6,                       haskell-src-meta        >= 0.8      && < 0.9,                       hint                    >= 0.7      && < 0.10,@@ -182,12 +182,12 @@                       prettyprinter-interp    ^>= 0.2,                       pretty-show             >= 1.9      && < 2.0,                       primitive               >= 0.5.0.1  && < 1.0,-                      string-interpolate      ^>= 0.3,+                      string-interpolate      >= 0.3      && < 1.1,                       template-haskell        >= 2.20.0.0  && < 2.24,                       temporary               >= 1.2.1    && < 1.4,                       terminal-size           >= 0.3      && < 0.4,                       text                    >= 1.2.2    && < 2.2,-                      time                    >= 1.4.0.1  && < 1.15,+                      time                    >= 1.4.0.1  && < 1.17,                       transformers            >= 0.6.1.0  && < 0.7,                       trifecta                >= 1.7.1.1  && < 2.2,                       vector                  >= 0.11     && < 1.0,

@@ -14,7 +14,7 @@       :: Integer -> Natural'     template: |-       -- integerToNaturalThrow begin-      ~RESULT <= ~ERRORO when ~ARG[0] < ~SIZE[~TYP[0]]'d0 else+      ~RESULT <= ~ERRORO when ~ARG[0] < to_signed(0,~SIZE[~TYP[0]]) else                  resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]);       -- integerToNaturalThrow end     warning: 'GHC.Num.Integer.integerToNaturalThrow: Naturals are dynamically sized@@ -27,7 +27,7 @@       :: Integer -> Natural'     template: |-       -- integerToNaturalClamp begin-      ~RESULT <= to_unsigned(0,~SIZE[~TYPO]]) when ~ARG[0] < ~SIZE[~TYP[0]]'d0 else+      ~RESULT <= to_unsigned(0,~SIZE[~TYPO]) when ~ARG[0] < to_signed(0,~SIZE[~TYP[0]]) else                  resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]);       -- integerToNaturalClamp end     warning: 'GHC.Num.Integer.integerToNaturalClamp: Naturals are dynamically sized

@@ -16,16 +16,19 @@ import Data.Hashable               (Hashable) import Control.DeepSeq             (NFData) +-- Orphan instances:+--+--   Binary Name+--   Binary OccName+--   Binary NameFlavour+--   Binary ModName+--   Binary NameSpace+--   Binary PkgName+import GHCi.TH.Binary ()+ instance Binary TopEntityT instance Binary TopEntity instance Binary PortName--instance Binary Name-instance Binary OccName-instance Binary NameFlavour-instance Binary ModName-instance Binary NameSpace-instance Binary PkgName  instance Hashable TopEntityT instance Hashable TopEntity

@@ -970,14 +970,18 @@ architecture :: Component -> VHDLM Doc architecture c = do {   ; syn <- Ap hdlSyn-  ; let attrs = case syn of+  -- The entity declarative region is implicitly visible inside the+  -- architecture, so re-declaring `attribute X : T;` here for an `X` already+  -- declared by the entity produces a duplicate declaration that GHDL rejects.+  -- Skip declarations for any (name, type) pair already emitted by the entity.+  ; let (entityDeclared, attrs) = case syn of                   -- See: [Note] Hack entity attributes in architecture-                  Other -> declAttrs-                  _     -> inputAttrs ++ outputAttrs ++ declAttrs+                  Other -> (entityDeclaredAttrTypes c, declAttrs)+                  _     -> (mempty, inputAttrs ++ outputAttrs ++ declAttrs)   ; nest 2       (("architecture structural of" <+> pretty (componentName c) <+> "is" <> line <>        decls (declarations c)) <> line <>-       if null attrs then emptyDoc else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> line <>+       if null attrs then emptyDoc else line <> line <> renderAttrsSkippingDecls (TextS.pack "signal") entityDeclared attrs) <> line <>     nest 2       ("begin" <> line <>        insts (declarations c)) <> line <>@@ -993,6 +997,14 @@    isNetDecl NetDecl'{} = True    isNetDecl _          = False +-- | The (name, type) pairs of attribute declarations emitted by 'entity' for a+-- given component. Only for input and output ports, not for any internal signals.+entityDeclaredAttrTypes :: Component -> HashMap TextS.Text TextS.Text+entityDeclaredAttrTypes c = attrTypes (map snd (inputAttrs ++ outputAttrs))+ where+  inputAttrs  = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype]+  outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype]+ attrType ::   HashMap TextS.Text TextS.Text ->   Attr TextS.Text ->@@ -1001,10 +1013,11 @@   case HashMap.lookup name' types of     Nothing    -> HashMap.insert name' type' types     Just type'' | type'' == type' -> types-                | otherwise -> error $-                      $(curLoc) ++ unwords [ TextS.unpack name', "already assigned"-                                           , TextS.unpack type'', "while we tried to"-                                           , "add", TextS.unpack type' ]+                | otherwise -> error $ [I.i|+                    Synthesis attribute '#{TextS.unpack name'}' was declared with+                    conflicting types '#{TextS.unpack type''}' and '#{TextS.unpack type'}'.+                    An attribute must have a single type across the entire design.+                  |]  where   name' = attrName attr   type' = case attr of@@ -1054,15 +1067,28 @@   :: TextS.Text   -> [(Identifier, Attr TextS.Text)]   -> VHDLM Doc-renderAttrs what (attrMap -> attrs) =+renderAttrs what = renderAttrsSkippingDecls what HashMap.empty++-- | Like 'renderAttrs', but skip emitting the @attribute X : T;@ declaration+-- line for any name that appears in the supplied @name -> type@ map with the+-- same type.+renderAttrsSkippingDecls+  :: TextS.Text+  -> HashMap TextS.Text TextS.Text+  -> [(Identifier, Attr TextS.Text)]+  -> VHDLM Doc+renderAttrsSkippingDecls what skipDecls (attrMap -> attrs) =   vcat $ sequence $ intersperse " " $ map renderAttrGroup (HashMap.toList attrs)  where   renderAttrGroup     :: (TextS.Text, (TextS.Text, [(TextS.Text, TextS.Text)]))     -> VHDLM Doc   renderAttrGroup (attrname, (typ, elems)) =-    ("attribute" <+> stringS attrname <+> colon <+> stringS typ <> semi)-    <> line <>+    (if HashMap.lookup attrname skipDecls == Just typ+       then emptyDoc+       else ("attribute" <+> stringS attrname <+> colon <+> stringS typ <> semi)+            <> line)+    <>     (vcat $ sequence $ map (renderAttrDecl attrname) elems)    renderAttrDecl

@@ -20,7 +20,8 @@ import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet) import Clash.Unique (fromGhcUnique) import Clash.Core.DataCon (dcUniq)-import GHC.Builtin.Names (unsafeReflDataConKey, eqPrimTyConKey, typeNatAddTyFamNameKey)+import GHC.Builtin.Names+  (unsafeReflDataConKey, eqPrimTyConKey, eqTyConKey, typeNatAddTyFamNameKey)  -- | Data type that indicates what kind of solution (if any) was found data TypeEqSolution@@ -177,6 +178,14 @@  case tyView (coreView tcm ty) of   TyConApp tc [_, _, left, right]     | nameUniq tc == fromGhcUnique eqPrimTyConKey ->+    Just (coreView tcm left, coreView tcm right)+  TyConApp tc [_, left, right]+    -- Lifted equality (~): @(~) :: forall k. k -> k -> Constraint@+    --+    -- Note that lifted equality exists to house "bogus" types, i.e. a deferred+    -- type error. Clash doesn't support that, so we can treat lifted equality+    -- (~) the same as unlifted equality (~#).+    | nameUniq tc == fromGhcUnique eqTyConKey ->     Just (coreView tcm left, coreView tcm right)   _ ->     Nothing

@@ -58,8 +58,8 @@   | Word16Literal   !Integer   | Word32Literal   !Integer   | StringLiteral   !String-  | FloatLiteral    !Word32-  | DoubleLiteral   !Word64+  | FloatLiteral    !Word32  -- See Note [Storage of floating point in Literal]+  | DoubleLiteral   !Word64  -- See Note [Storage of floating point in Literal]   | CharLiteral     !Char   | NaturalLiteral  !Integer   | ByteArrayLiteral !ByteArray

@@ -35,7 +35,7 @@ import Data.Default                     (Default(..)) import Data.Text                        (Text) import Control.Monad.Identity-import Data.Binary.IEEE754              (wordToDouble, wordToFloat)+import GHC.Float                        (castWord32ToFloat, castWord64ToDouble) import Data.List.Extra                  ((<:>)) import qualified Data.Text              as T import Data.Maybe                       (fromMaybe)@@ -374,8 +374,8 @@     Word8Literal w     -> pretty w <> "##8"     Word16Literal w    -> pretty w <> "##16"     Word32Literal w    -> pretty w <> "##32"-    FloatLiteral w     -> pretty (wordToFloat w) <> "#"-    DoubleLiteral w    -> pretty (wordToDouble w) <> "##"+    FloatLiteral w     -> pretty (castWord32ToFloat w) <> "#"+    DoubleLiteral w    -> pretty (castWord64ToDouble w) <> "##"     CharLiteral c      -> pretty c <> "#"     StringLiteral s    -> vcat $ map pretty $ showMultiLineString s     NaturalLiteral n   -> pretty n

@@ -54,6 +54,7 @@   , normalizeType   , varAttrs   , typeAttrs+  , stripAnnTypes   ) where @@ -364,6 +365,12 @@ typeAttrs :: Type -> [Attr Text] typeAttrs (AnnType attrs _typ) = attrs typeAttrs _                    = []++-- | Remove all 'AnnType' wrappers from a type, returning the underlying type+-- without any synthesis attributes.+stripAnnTypes :: Type -> Type+stripAnnTypes (AnnType _ typ) = stripAnnTypes typ+stripAnnTypes typ             = typ  -- | Is a type a function type? isFunTy :: TyConMap

@@ -167,7 +167,7 @@   if maxN >= 1 then     first fst (go maxN (supply,inScope) vec)   else-    error "extractElems must be called with positive number"+    error "extractElems must be called with maxN >= 1"  where   go :: Integer -> (Supply,InScopeSet) -> Term      -> ((Supply,InScopeSet),NonEmpty (Term, NonEmpty (Id, Term)))

@@ -25,7 +25,7 @@ import           Control.Concurrent               (MVar, modifyMVar, modifyMVar_, newMVar, withMVar) import           Control.Concurrent.Async         (mapConcurrently_) import           Control.DeepSeq-import           Control.Exception                (throw, Exception)+import           Control.Exception                (evaluate, throw, Exception) import qualified Control.Monad                    as Monad import           Control.Monad                    (unless, foldM, forM) import           Control.Monad.Catch              (MonadMask, MonadThrow (throwM))@@ -120,6 +120,7 @@ import           Clash.Netlist.Types   (IdentifierText, BlackBox (..), Component (..), FilteredHWType, HWMap, SomeBackend (..),    TopEntityT(..), TemplateFunction, ComponentMap, findClocks, ComponentMeta(..))+import           Clash.Netlist.Util               (checkTopEntityPorts) import           Clash.Normalize                  (checkNonRecursive, cleanupGraph,                                                    normalize, runNormalization) import           Clash.Normalize.Util             (callGraph, tvSubstWithTyEq)@@ -394,7 +395,7 @@   -- Get manifest file if cache is not stale and caching is enabled. This is used   -- to prevent unnecessary recompilation.   clashModDate <- getClashModificationDate-  (userModifications, maybeManifest, topHash) <-+  (userModifications, maybeManifest, topHashWithSubHashes) <-     readFreshManifest topEntities0 (bindingsMap, topEntity) primMap opts clashModDate manPath    let topEntityNames = map topId (eltsVarEnv topEntityMap)@@ -434,7 +435,22 @@       -- files belonging to other top entities. Failing to do so leads to #463       prepareDir hdlDir opts userModifications -      -- 2. Normalize topEntity+      -- 2. Validate the top entity's 'Synthesize' port annotation. This is done+      -- before normalization so that "trivial" port errors are reported quickly,+      -- instead of only after a (potentially long) normalization (#3305).+      --+      -- 'annM' is already split (by 'splitTopEntityT') and 'topEntity' has been+      -- through 'removeForAll', so the types and ports line up; see+      -- 'checkTopEntityPorts' for how the check is kept equivalent to the one in+      -- 'mkUniqueNormalized'.+      --+      -- XXX: Because the types are split to match, reported errors may refer to+      --      ports the user didn't directly write.+      evaluate+        (checkTopEntityPorts typeTrans (envCustomReprs env) (envTyConMap env)+           topEntity annM)++      -- 3. Normalize topEntity       supplyN <- Supply.newSupply       transformedBindings <- normalizeEntity env bindingsMap typeTrans peEval                                eval topEntityNames supplyN topEntity@@ -445,7 +461,7 @@       withMVar ioLockV . const $         putStrLn ("Clash: Normalization took " ++ prepNormDiff) -      -- 3. Generate netlist for topEntity+      -- 4. Generate netlist for topEntity       (topComponent, netlist) <- modifyMVar seenV $ \seen -> do         (topComponent, netlist, seen') <-           -- TODO My word, this has far too many arguments.@@ -460,7 +476,7 @@       withMVar ioLockV . const $         putStrLn ("Clash: Netlist generation took " ++ normNetDiff) -      -- 4. Generate topEntity wrapper+      -- 5. Generate topEntity wrapper       (hdlDocs, dfiles, mfiles) <- withMVar seenV $ \seen ->         pure $! createHDL hdlState' opts modNameT seen netlist domainConfs topComponent topNmT @@ -492,7 +508,7 @@         manifest =           mkManifest             hdlState' domainConfs opts topComponent components depIds-            filesAndDigests1 topHash+            filesAndDigests1 topHashWithSubHashes       writeManifest manPath manifest        topTime <- hdlDocs `seq` Clock.getCurrentTime

@@ -125,11 +125,35 @@ instance FromJSON FilesManifest where   parseJSON = Aeson.withObject "FilesManifest" $ fmap FilesManifest . parseFiles +-- | Per-input subhashes of the @manifestHash@. Exposed as @__debug_hash@ in+-- the JSON manifest purely as a debugging aid: when two manifests disagree on+-- @hash@, comparing these fields tells you *which* input changed. The leading+-- double underscore and @debug@ in the name signal that downstream tools+-- should not rely on these — their existence, names, and contents may change+-- between Clash versions.+data DebugSubHashes = DebugSubHashes+  { dshTops :: ByteString+    -- ^ Hash of the full @[TopEntityT]@ list discovered in the design.+  , dshPrimMap :: ByteString+    -- ^ Hash of the compiled primitive map.+  , dshClashModDate :: ByteString+    -- ^ Hash of the @clash@ executable's modification time.+  , dshCallGraph :: ByteString+    -- ^ Hash of the call-graph closure of the top entity (i.e., the bindings+    -- that actually contribute to the generated HDL).+  , dshOpts :: ByteString+    -- ^ Hash of the (HDL-affecting subset of the) 'ClashOpts'.+  } deriving (Show, Read, Eq)+ -- | Information about the generated HDL between (sub)runs of the compiler data Manifest   = Manifest   { manifestHash :: ByteString     -- ^ Hash digest of the TopEntity and all its dependencies.+  , manifestDebugSubHashes :: Maybe DebugSubHashes+    -- ^ Per-input subhashes that feed into 'manifestHash'. Debug-only — see+    -- 'DebugSubHashes'. 'Nothing' when reading an older manifest that+    -- predates this field.   , successFlags  :: (Int, Int)     -- ^ Compiler flags used to achieve successful compilation:     --@@ -163,12 +187,36 @@     -- on any component listed before it, but not after it.   } deriving (Show,Read,Eq) +-- | JSON shape for 'DebugSubHashes'. All values are hex-encoded SHA256 digests.+instance ToJSON DebugSubHashes where+  toJSON DebugSubHashes{..} = Aeson.object+    [ "tops" .= toHexDigest dshTops+    , "prim_map" .= toHexDigest dshPrimMap+    , "clash_mod_date" .= toHexDigest dshClashModDate+    , "call_graph" .= toHexDigest dshCallGraph+    , "opts" .= toHexDigest dshOpts+    ]++instance FromJSON DebugSubHashes where+  parseJSON = Aeson.withObject "DebugSubHashes" $ \v ->+    DebugSubHashes+      -- See Note [Failed hex digest decodes]+      <$> (unsafeFromHexDigest <$> v .: "tops")+      <*> (unsafeFromHexDigest <$> v .: "prim_map")+      <*> (unsafeFromHexDigest <$> v .: "clash_mod_date")+      <*> (unsafeFromHexDigest <$> v .: "call_graph")+      <*> (unsafeFromHexDigest <$> v .: "opts")+ instance ToJSON Manifest where   toJSON (Manifest{..}) =-    Aeson.object+    Aeson.object $       [ "version" .= ("unstable" :: Text)       , "hash" .= toHexDigest manifestHash-      , "flags" .= successFlags+      ] <>+      (case manifestDebugSubHashes of+        Just sh -> ["__debug_hash" .= sh]+        Nothing -> []) <>+      [ "flags" .= successFlags         -- TODO: add nested ports (i.e., how Clash split/filtered arguments)       , "components" .= componentNames       , "top_component" .= Aeson.object@@ -236,6 +284,7 @@       Manifest             -- See Note [Failed hex digest decodes]         <$> (unsafeFromHexDigest <$> v .: "hash")+        <*> v .:? "__debug_hash"         <*> v .: "flags"         <*> (topComponent >>= (.: "ports_flat"))         <*> v .: "components"@@ -309,12 +358,13 @@   [Id] ->   -- | Files and  their hashes   [(FilePath, ByteString)] ->-  -- | Hash returned by 'readFreshManifest'-  ByteString ->+  -- | Hash and per-input subhashes returned by 'readFreshManifest'+  (ByteString, DebugSubHashes) ->   -- | New manifest   Manifest-mkManifest backend domains ClashOpts{..} Component{..} components deps files topHash = Manifest+mkManifest backend domains ClashOpts{..} Component{..} components deps files (topHash, subHashes) = Manifest   { manifestHash = topHash+  , manifestDebugSubHashes = if opt_debugManifestHash then Just subHashes else Nothing   , ports = inPorts <> inOutPorts <> outPorts   , componentNames = map Id.toText compNames   , topComponent = Id.toText componentName@@ -378,8 +428,9 @@   -- | Path to manifest file.   FilePath ->   -- | ( Nothing if no manifest file was found-  --   , Nothing on stale cache, disabled cache, or not manifest file found )-  IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString)+  --   , Nothing on stale cache, disabled cache, or not manifest file found+  --   , Top-level hash plus per-input subhashes used to derive it )+  IO (Maybe [UnexpectedModification], Maybe Manifest, (ByteString, DebugSubHashes)) readFreshManifest tops (bindingsMap, topId) primMap opts@(ClashOpts{..}) clashModDate path = do   modificationsM <- traverse (isUserModified path) =<< readManifest path @@ -387,7 +438,7 @@   pure     ( modificationsM     , checkManifest =<< if opt_cachehdl then manifestM else Nothing-    , topHash+    , (topHash, subHashes)     )   where@@ -433,12 +484,25 @@    -- TODO: Binary encoding does not account for alpha equivalence (nor should   --       it?), so the cache behaves more pessimisticly than it could.+  --+  -- Compute each input's digest independently so that they can be surfaced+  -- via 'manifestDebugSubHashes'. The top-level hash is then a digest of the+  -- subhashes — keeping it a deterministic function of the same inputs while+  -- making it mechanically obvious which input changed between two runs.+  subHashes = DebugSubHashes+    { dshTops = Sha256.hashlazy (Binary.encode tops)+    , dshPrimMap = Sha256.hashlazy (Binary.encode (hashCompiledPrimMap primMap))+    , dshClashModDate = Sha256.hashlazy (Binary.encode (show clashModDate))+    , dshCallGraph = Sha256.hashlazy (Binary.encode (callGraphBindings bindingsMap topId))+    , dshOpts = Sha256.hashlazy (Binary.encode optsHash)+    }+   topHash = Sha256.hashlazy $ Binary.encode-    ( tops-    , hashCompiledPrimMap primMap-    , show clashModDate-    , callGraphBindings bindingsMap topId-    , optsHash+    ( dshTops subHashes+    , dshPrimMap subHashes+    , dshClashModDate subHashes+    , dshCallGraph subHashes+    , dshOpts subHashes     )    checkManifest manifest@Manifest{manifestHash,successFlags}

@@ -404,6 +404,14 @@   -- investigating bugs, because it will make log output deterministic.   --   -- Command line flag: -fclash-no-concurrent-topentity-compilation+  , opt_debugManifestHash :: Bool+  -- ^ Emit a @__debug_hash@ field in @clash-manifest.json@ containing the+  -- SHA256 of each input that feeds into the top-level @hash@. This is a+  -- debugging aid for diagnosing cache misses across builds that produce+  -- identical HDL: diffing two manifests' @__debug_hash@ fields reveals+  -- /which/ input changed.+  --+  -- Command line flag: -fclash-debug-manifest-hash   }   deriving (Show, Eq, NFData, Generic, Hashable) @@ -444,6 +452,7 @@   --      https://github.com/clash-lang/clash-compiler/issues/2762.   , opt_ignoreBrokenGhcs    = unsafeLookupEnvBool "CLASH_IGNORE_BROKEN_GHCS" False   , opt_concurrentTopEntities = True+  , opt_debugManifestHash   = False   }  -- | Synopsys Design Constraint (SDC) information for a component.

@@ -553,18 +553,7 @@               [Right _,Left (Data dc)] -> do                 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 declType (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"-                    netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr-                    return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)+              [Right _,Left scrut] -> mkDataToTag declType assignTy scrut               _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args)            | pNm `elem`@@ -572,18 +561,7 @@               [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-                (scrutExpr,scrutDecls) <--                  mkExpr False declType (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"-                    netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr-                    return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)+              [Right _, Right _,Left scrut] -> mkDataToTag declType assignTy scrut               _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args)            | pNm == "Clash.Explicit.SimIO.mealyIO" -> do@@ -789,6 +767,58 @@       Nothing -> pure Nothing       Just ([id_],[nm_],decls) -> pure (Just (id_,nm_,decls))       _ -> error "internal error"++-- | Lower a non-constant @dataToTag# scrut@ to netlist. For plain @Sum@/@SP@+-- types, the bits stored in @scrut@ /are/ the GHC tag, so a 'DataTag' netlist+-- expression that the backend renders as a bit-extract is sufficient. For+-- types with a user-defined bit representation (@CustomSum@, @CustomSP@,+-- @CustomProduct@) the stored bits are arbitrary, so we lower to a+-- 'CondAssignment' that maps each constructor's custom bit pattern back to+-- its GHC tag (@dcTag - 1@). See issue #2724.+mkDataToTag+  :: HasCallStack+  => DeclarationType+  -> Usage+  -> Term+  -> NetlistMonad (Expr, [Declaration])+mkDataToTag declType assignTy scrut = do+  tcm      <- Lens.view tcCache+  let scrutTy = inferCoreTypeOf tcm scrut+  scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+  (scrutExpr, scrutDecls) <-+    mkExpr False declType (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut+  (scrutId, scrutDecls') <- case scrutExpr of+    Identifier id_ Nothing -> pure (id_, scrutDecls)+    _ -> do+      tmpRhs <- Id.make "c$dtt_rhs"+      netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr+      pure (tmpRhs, netDecl ++ scrutDecls)+  let nReprs = case scrutHTy of+        CustomSum _ _ _ reprs -> Just (length reprs)+        CustomSP  _ _ _ reprs -> Just (length reprs)+        CustomProduct {}      -> Just 1+        _                     -> Nothing+  case nReprs of+    Nothing -> pure (DataTag scrutHTy (Right scrutId), scrutDecls')+    Just k -> do+      iw <- Lens.view intWidth+      let sIw = Signed iw+      if k <= 1+        then pure ( N.Literal (Just (sIw, iw)) (NumLit 0)+                  , scrutDecls' )+        else do+          tag <- Id.make "c$dtt_tag"+          let alts = [ ( Just (NumLit (toInteger i))+                       , N.Literal (Just (sIw, iw)) (NumLit (toInteger i)))+                     | i <- [0 .. k - 1] ]+              tagDecl = NetDecl' Nothing tag sIw Nothing+          assn <- N.condAssign tag sIw (Identifier scrutId Nothing) scrutHTy alts+          -- Wrap the tag identifier in an identity 'DataCon' so the caller's+          -- catch-all assignment fires (an 'Identifier _ Nothing' would be+          -- skipped, leaving the destination unassigned). All backends render+          -- 'DataCon _ (DC (Void {}, -1)) [e]' as 'e' verbatim.+          pure ( N.DataCon sIw (DC (Void Nothing, -1)) [Identifier tag Nothing]+               , tagDecl : assn : scrutDecls' )  -- | Turn a 'mealyIO' expression into a two sequential processes, one "initial" -- process for the starting state, and one clocked sequential process.

@@ -364,7 +364,8 @@   | otherwise = unsafePerformIO $ do       let candidates = map (</> toCanonicalize) (nubOrd idirs)       found <- filterM doesFileExist candidates-      case found of+      canonicalized <- nubOrd <$> mapM canonicalizePath found+      case canonicalized of         [] -> error [I.i|           Could not find data file #{show toCanonicalize}. The following directories were           searched:@@ -373,11 +374,10 @@         (_:_:_) -> error [I.i|           Multiple data files for #{show toCanonicalize} found. The following candidates           were found:-            #{found}+            #{canonicalized}           Please disambiguate data files.         |]-        [c] ->-          canonicalizePath c+        [c] -> pure c {-# NOINLINE canonicalizeDataFilePath #-} -- To contain unsafePerformIO  -- | Select a new file name that doesn't collide with existing names. Might return

@@ -101,9 +101,9 @@   (TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons) import           Clash.Core.Type   (LitTy (..), Type (..), TyVar, TypeView (..), coreView, coreView1, normalizeType,-   splitTyConAppM, tyView)+   splitCoreFunForallTy, splitTyConAppM, stripAnnTypes, tyView) import           Clash.Core.Util-  (substArgTys, tyLitShow)+  (splitShouldSplit, substArgTys, tyLitShow) import           Clash.Core.Var   (Id, Var (..), mkLocalId, modifyVarName) import           Clash.Core.VarEnv@@ -815,8 +815,12 @@             pure (res1, Nothing, subst0)           Just (_, newName0) -> do             -- Result binder was renamed. We cannot rename 'res1', so we need-            -- to create an indirection.-            ([newName1], s) <- mkUnique subst0 [newName0]+            -- to create an indirection. The indirection binder is an internal+            -- signal, so it must not inherit any 'AnnType' synthesis attributes+            -- attached to the top entity's return type; those belong on the+            -- output port only. See #3224.+            let newName0' = newName0 { varType = stripAnnTypes (coreTypeOf newName0) }+            ([newName1], s) <- mkUnique subst0 [newName0']             pure (newName1, Just (res1, Var newName1), s)        let@@ -1959,6 +1963,84 @@   -- | Something was annotated as being a PortProduct, but wasn't one   | PortProductError PortName HWType +-- | Render an 'ExpandError' as a human readable error message.+expandErrorMessage :: ExpandError -> String+expandErrorMessage (AttrError attrs) = [I.i|+  Cannot use attribute annotations on product types of top entities. Saw+  annotation:++    #{attrs}+|]+expandErrorMessage (PortProductError pn hwty) = [I.i|+  Saw a PortProduct in a Synthesize annotation:++    #{pn}++  but the port type:++    #{hwty}++  is not a product!+|]++-- | Like 'expandTopEntityOrErrM', but pure: expands the top entity and throws a+-- formatted error (via 'expandErrorMessage') if the annotation is invalid.+expandTopEntityOrErr+  :: HasCallStack+  => [(Maybe Id, FilteredHWType)]+  -- ^ Arguments. Ids are used as name hints.+  -> (Maybe Id, FilteredHWType)+  -- ^ Result. Id is used as name hint.+  -> Maybe TopEntity+  -- ^ If /Nothing/, an expanded top entity will be generated as if /defSyn/+  -- was passed.+  -> ExpandedTopEntity (Either Text Text)+expandTopEntityOrErr ihwtys ohwty topM =+  case expandTopEntity ihwtys ohwty topM of+    Left err -> error (expandErrorMessage err)+    Right eTop -> eTop++-- | Check the 'Synthesize' port annotation of a top entity against the types+-- of its arguments and result, throwing an error if the annotation is invalid.+--+-- The annotation is expected to already be split (see+-- 'Clash.Driver.splitTopEntityT'); the argument types are split to match before+-- checking.+checkTopEntityPorts+  :: HasCallStack+  => (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcoded 'Type' -> 'HWType' translator+  -> CustomReprs+  -> TyConMap+  -> Id+  -- ^ Top entity binder+  -> Maybe TopEntity+  -- ^ Top entity annotation, if any. Expected to be already split, see above.+  -> ()+checkTopEntityPorts typeTrans reprs tcm topId topM =+  let+    (argTys, resTy) = splitCoreFunForallTy tcm (coreTypeOf topId)+    -- Only value arguments carry ports; type/dictionary arguments are skipped.+    -- 'splitShouldSplit' mirrors 'separateArguments', so the resulting types+    -- align with the (already split) ports in the annotation.+    valArgTys = splitShouldSplit tcm [ty | Right ty <- argTys]+    convert = coreTypeToHWType typeTrans reprs tcm+    hwtysE =+      flip evalState mempty $+        sequence <$> mapM convert (valArgTys ++ [resTy])+  in+    case hwtysE of+      -- A port type is polymorphic or otherwise untranslatable. Skip the check+      -- and let normalization produce its (clearer) diagnostic (e.g. "can only+      -- normalize monomorphic functions" or "non-representable return type").+      Left _ -> ()+      Right hwtys ->+        let (argHwtys, resHwty) = (init hwtys, last hwtys)+        -- Force the expansion, which throws on an invalid annotation.+        in expandTopEntityOrErr (map (Nothing,) argHwtys) (Nothing, resHwty) topM+             `seq` ()+ -- | Same as 'expandTopEntity', but also adds identifiers to the identifier -- set of the monad. expandTopEntityOrErrM@@ -1976,31 +2058,10 @@   -- IdentifierSet. expandTopEntityOrErrM ihwtys ohwty topM = do   is <- identifierSetM id--  case expandTopEntity ihwtys ohwty topM of-    Left (AttrError attrs) ->-      (error [I.i|-        Cannot use attribute annotations on product types of top entities. Saw-        annotation:--          #{attrs}-      |])-    Left (PortProductError pn hwty) ->-      (error [I.i|-        Saw a PortProduct in a Synthesize annotation:--          #{pn}--        but the port type:--          #{hwty}--        is not a product!-      |])-    Right eTop -> do-      let ete = evalState (traverse (either Id.addRaw Id.makeBasic) eTop) (Id.clearSet is)-      Id.addMultiple (toList ete)-      pure ete+  let eTop = expandTopEntityOrErr ihwtys ohwty topM+  let ete = evalState (traverse (either Id.addRaw Id.makeBasic) eTop) (Id.clearSet is)+  Id.addMultiple (toList ete)+  pure ete  -- | Take a top entity and /expand/ its port names. I.e., make sure that every -- port that should be generated in the HDL is part of the data structure. It

@@ -19,10 +19,14 @@ import           Control.Exception                (throw) import qualified Control.Lens                     as Lens import           Control.Monad                    ((>=>), when)+import           Control.Monad.IO.Class           (liftIO) import           Control.Monad.State.Strict       (State) import           Data.Default                     (def) import           Data.Either                      (lefts,partitionEithers) import qualified Data.IntMap                      as IntMap+import qualified Data.IORef                       as IORef+import           Clash.Data.UniqMap               (UniqMap)+import qualified Clash.Data.UniqMap               as UniqMap import           Data.List   (intersect, mapAccumL) import qualified Data.Map                         as Map@@ -71,7 +75,7 @@ import           Clash.Normalize.Types import           Clash.Normalize.Util import           Clash.Rewrite.Combinators-  ((>->), (!->), bottomupR, repeatR, topdownR)+  ((>->), (!->), bottomupR, repeatR, topdownFixR) import           Clash.Rewrite.Types   (RewriteEnv (..), RewriteState (..), bindings, debugOpts, extra,    tcCache, topEntities, newInlineStrategy)@@ -85,7 +89,6 @@ import qualified Data.ByteString                  as BS import qualified Data.ByteString.Lazy             as BL -import           System.IO.Unsafe                 (unsafePerformIO) import           Clash.Rewrite.Types (RewriteStep(..))  @@ -258,7 +261,8 @@   -> NormalizeSession BindingMap cleanupGraph topEntity norm   | Just ct <- mkCallTree [] norm topEntity-  = do ctFlat <- flattenCallTree ct+  = do cache <- liftIO (IORef.newIORef UniqMap.empty)+       ctFlat <- flattenCallTree cache ct        return (mkVarEnv $ snd $ callTreeToList [] ctFlat) cleanupGraph _ norm = return norm @@ -342,74 +346,93 @@            then return (Right ((nm,e),us))            else return (Left b) +-- | Flatten a 'CallTree', memoizing results by binder Id within one cleanup+-- pass. Without the cache, every binder reachable from the root is flattened+-- as many times as it appears in the (un-deduplicated) call tree. flattenCallTree-  :: CallTree+  :: IORef.IORef (UniqMap CallTree)+  -- ^ Memo cache, keyed by binder Id. Local to one 'cleanupGraph' call.+  -> CallTree   -> NormalizeSession CallTree-flattenCallTree c@(CLeaf _) = return c-flattenCallTree (CBranch (nm,(Binding nm' sp inl pr tm r)) used) = do-  flattenedUsed   <- mapM flattenCallTree used-  (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed-  let (toInline,il_used) = unzip il_ct-      subst = extendGblSubstList (mkSubst emptyInScopeSet) toInline-  newExpr <- case toInline of-    [] -> return tm-    _  -> do-      let tm1 = substTm "flattenCallTree.flattenExpr" subst tm+flattenCallTree _ c@(CLeaf _) = return c+flattenCallTree cache (CBranch (nm,(Binding nm' sp inl pr tm r)) used) = do+  -- XXX: Careful! If you ever add concurrency, this will have to be changed to+  --      account for multiple workers.+  cached <- liftIO (UniqMap.lookup nm <$> IORef.readIORef cache)+  case cached of+    Just ct -> pure ct+    Nothing -> do+      ct <- doFlatten+      liftIO (IORef.modifyIORef' cache (UniqMap.insert nm ct))+      pure ct+ where+  doFlatten = do+   flattenedUsed   <- mapM (flattenCallTree cache) used+   (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed+   let (toInline,il_used) = unzip il_ct+       subst = extendGblSubstList (mkSubst emptyInScopeSet) toInline+   newExpr <- case toInline of+     [] -> return tm+     _  -> do+       let tm1 = substTm "flattenCallTree.flattenExpr" subst tm -      -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps-      opts <- Lens.view debugOpts-      let rewriteHistFile = dbg_historyFile opts-      when (Maybe.isJust rewriteHistFile) $-        let !_ = unsafePerformIO-             $ BS.appendFile (Maybe.fromJust rewriteHistFile)-             $ BL.toStrict-             $ encode RewriteStep-                 { t_ctx    = []-                 , t_name   = "INLINE"-                 , t_bndrS  = showPpr (varName nm')-                 , t_before = tm-                 , t_after  = tm1-                 }-        in pure ()-      rewriteExpr ("flattenExpr",flatten) (showPpr nm, tm1) (nm', sp)-  let allUsed = newUsed ++ concat il_used-  -- inline all components when the resulting expression after flattening-  -- is still considered "cheap". This happens often at the topEntity which-  -- wraps another functions and has some selectors and data-constructors.-  if not (isNoInline inl) && isCheapFunction newExpr-     then do-        let (toInline',allUsed') = unzip (map goCheap allUsed)-            subst' = extendGblSubstList (mkSubst emptyInScopeSet)-                                        (Maybe.catMaybes toInline')-        let tm1 = substTm "flattenCallTree.flattenCheap" subst' newExpr-        newExpr' <- rewriteExpr ("flattenCheap",flatten) (showPpr nm, tm1) (nm', sp)-        return (CBranch (nm,(Binding nm' sp inl pr newExpr' r)) (concat allUsed'))-     else return (CBranch (nm,(Binding nm' sp inl pr newExpr r)) allUsed)-  where-    flatten =-      repeatR (topdownR (apply "appProp" appProp >->-                 apply "bindConstantVar" bindConstantVar >->-                 apply "caseCon" caseCon >->-                 (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >->-                 apply "reduceNonRepPrim" reduceNonRepPrim >->-                 apply "removeUnusedExpr" removeUnusedExpr) >->-               bottomupR (apply "flattenLet" flattenLet)) !->-      topdownSucR (apply "topLet" topLet) >->-      -- See [Note] relation `collapseRHSNoops` and `inlineCleanup`-      -- Note that we do this as the very last step, after all constant propagation-      -- has been done to avoid #3036.-      topdownSucR (apply "collapseRHSNoops" collapseRHSNoops) >->-      topdownSucR (apply "inlineCleanup" inlineCleanup) >->-      bottomupR (apply "caseCon" caseCon) >-> -- https://github.com/clash-lang/clash-compiler/issues/3159 / #3204-      bottomupR (apply "flattenLet" flattenLet) >-> -- https://github.com/clash-lang/clash-compiler/issues/3185-      topdownSucR (apply "topLet" topLet)+       -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps+       opts <- Lens.view debugOpts+       let rewriteHistFile = dbg_historyFile opts+       when (Maybe.isJust rewriteHistFile) $+         liftIO+           $ BS.appendFile (Maybe.fromJust rewriteHistFile)+           $ BL.toStrict+           $ encode RewriteStep+               { t_ctx    = []+               , t_name   = "INLINE"+               , t_bndrS  = showPpr (varName nm')+               , t_before = tm+               , t_after  = tm1+               }+       rewriteExpr ("flattenExpr",flatten) (showPpr nm, tm1) (nm', sp)+   let allUsed = newUsed ++ concat il_used+   -- inline all components when the resulting expression after flattening+   -- is still considered "cheap". This happens often at the topEntity which+   -- wraps another functions and has some selectors and data-constructors.+   if not (isNoInline inl) && isCheapFunction newExpr+      then do+         let (toInline',allUsed') = unzip (map goCheap allUsed)+             subst' = extendGblSubstList (mkSubst emptyInScopeSet)+                                         (Maybe.catMaybes toInline')+         let tm1 = substTm "flattenCallTree.flattenCheap" subst' newExpr+         newExpr' <- rewriteExpr ("flattenCheap",flatten) (showPpr nm, tm1) (nm', sp)+         return (CBranch (nm,(Binding nm' sp inl pr newExpr' r)) (concat allUsed'))+      else return (CBranch (nm,(Binding nm' sp inl pr newExpr r)) allUsed) -    goCheap c@(CLeaf   (nm2,(Binding _ _ inl2 _ e _)))-      | isNoInline inl2  = (Nothing     ,[c])-      | otherwise        = (Just (nm2,e),[])-    goCheap c@(CBranch (nm2,(Binding _ _ inl2 _ e _)) us)-      | isNoInline inl2  = (Nothing, [c])-      | otherwise        = (Just (nm2,e),us)+  flatten =+    -- topdownFixR reaches a fixpoint for the top-down propagation bundle.+    -- Keep flattenLet in the outer fixed-point loop: flattening can expose+    -- fresh propagation redexes for the next top-down pass.+    repeatR (topdownFixR (apply "appProp" appProp >->+               apply "bindConstantVar" bindConstantVar >->+               apply "caseCon" caseCon >->+               (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >->+               apply "reduceNonRepPrim" reduceNonRepPrim >->+               apply "removeUnusedExpr" removeUnusedExpr) >->+             bottomupR (apply "flattenLet" flattenLet)) !->+    topdownSucR (apply "topLet" topLet) >->+    -- See [Note] relation `collapseRHSNoops` and `inlineCleanup`+    -- Note that we do this as the very last step, after all constant propagation+    -- has been done to avoid #3036.+    topdownSucR (apply "collapseRHSNoops" collapseRHSNoops) >->+    topdownSucR (apply "inlineCleanup" inlineCleanup) >->+    bottomupR (apply "caseCon" caseCon) >-> -- https://github.com/clash-lang/clash-compiler/issues/3159 / #3204+    bottomupR (apply "flattenLet" flattenLet) >-> -- https://github.com/clash-lang/clash-compiler/issues/3185+    bottomupR (apply "bindConstantVar" bindConstantVar) >-> -- https://github.com/clash-lang/clash-compiler/issues/3041+    topdownSucR (apply "topLet" topLet)++  goCheap c@(CLeaf   (nm2,(Binding _ _ inl2 _ e _)))+    | isNoInline inl2  = (Nothing     ,[c])+    | otherwise        = (Just (nm2,e),[])+  goCheap c@(CBranch (nm2,(Binding _ _ inl2 _ e _)) us)+    | isNoInline inl2  = (Nothing, [c])+    | otherwise        = (Just (nm2,e),us)  callTreeToList :: [Id] -> CallTree -> ([Id], [(Id, Binding Term)]) callTreeToList visited (CLeaf (nm,bndr))

@@ -89,6 +89,8 @@ import           Clash.Core.VarEnv                (extendInScopeSetList) import qualified Clash.Data.UniqMap as UniqMap import qualified Clash.Normalize.Primitives as NP (undefined)+import           Clash.Sized.RTree                (RTree)+import           Clash.Sized.Vector               (Vec) import {-# SOURCE #-} Clash.Normalize.Strategy import           Clash.Normalize.Types import           Clash.Rewrite.Types@@ -264,7 +266,7 @@   go tcm (coreView1 tcm -> Just ty') = go tcm ty'   go tcm (tyView -> TyConApp vecTcNm _)     | Just vecTc <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec     , [nilCon, consCon] <- tyConDataCons vecTc     = do       uniqs0 <- Lens.use uniqSupply@@ -297,7 +299,7 @@   go tcm (coreView1 tcm -> Just ty) = go tcm ty   go tcm (tyView -> TyConApp vecTcNm _)     | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , nameOcc vecTcNm == showt ''Vec     , [nilCon, consCon] <- tyConDataCons vecTc     = if n == 0 then         mkVecNil nilCon resElTy@@ -342,7 +344,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [nilCon,consCon] <- tyConDataCons vecTc       = if n == 0 then           mkVecNil nilCon argElTy@@ -385,7 +387,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [nilCon,consCon] <- tyConDataCons vecTc       = do         uniqs0 <- Lens.use uniqSupply@@ -492,7 +494,7 @@     go tcm apDictTcNm (coreView1 tcm -> Just ty') = go tcm apDictTcNm ty'     go tcm apDictTcNm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [nilCon,consCon] <- tyConDataCons vecTc       = fmap (Maybe.fromMaybe (error "reduceTraverse: failed to build")) $ runMaybeT $ do           uniqs0 <- Lens.use uniqSupply@@ -535,10 +537,14 @@               fmapTm = Case (Var functorDictId) fmapTy                             [(fnPat, Var fmapId)] -              (uniqs3,(vars,elems)) = second (second sconcat . NE.unzip)-                                    $ uncurry extractElems uniqs2 consCon aTy 'T' n arg+              (uniqs3,vars,elemBinds)+                | n == 0    = (fst uniqs2,[],[])+                | otherwise =+                    let (us,(vs,es)) = second (second sconcat . NE.unzip)+                                     $ uncurry extractElems uniqs2 consCon aTy 'T' n arg+                    in  (us,NE.toList vs,NE.init es) -              funApps = map (fun1 `App`) (NE.toList vars)+              funApps = map (fun1 `App`) vars                lbody   = mkTravVec vecTcNm nilCon consCon (Var (apDictIds!!1))                                                         (Var (apDictIds!!2))@@ -549,7 +555,7 @@                                 ,((apDictIds!!1), pureTm)                                 ,((apDictIds!!2), apTm)                                 ,((funcDicIds!!0), fmapTm)-                                ] ++ NE.init elems) lbody+                                ] ++ elemBinds) lbody           uniqSupply Lens..= uniqs3           lift (changed lb)     go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showPpr ty@@ -630,7 +636,7 @@   where     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)-      | nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      | nameOcc vecTcNm == showt ''Vec       , Just vecTc <- UniqMap.lookup vecTcNm tcm       , [_nilCon, consCon] <- tyConDataCons vecTc       = let@@ -673,7 +679,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do         uniqs0 <- Lens.use uniqSupply@@ -722,7 +728,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do         uniqs0 <- Lens.use uniqSupply@@ -779,7 +785,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do         uniqs0 <- Lens.use uniqSupply@@ -807,7 +813,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do         uniqs0 <- Lens.use uniqSupply@@ -836,7 +842,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do         uniqs0 <- Lens.use uniqSupply@@ -867,7 +873,7 @@   go tcm (coreView1 tcm -> Just ty') = go tcm ty'   go tcm (tyView -> TyConApp vecTcNm _)     | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , nameOcc vecTcNm == showt ''Vec     , [nilCon, consCon]  <- tyConDataCons vecTc     = if n == 0 then         mkVecNil nilCon aTy@@ -907,7 +913,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do uniqs0 <- Lens.use uniqSupply            let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)@@ -939,7 +945,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [nilCon,consCon] <- tyConDataCons vecTc       , let innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy m), aTy]       = if n == 0 then@@ -1002,7 +1008,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [nilCon,consCon] <- tyConDataCons vecTc       = let nilVec           = mkVec nilCon consCon aTy 0 []             innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]@@ -1026,7 +1032,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [nilCon,consCon] <- tyConDataCons vecTc       = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg)         in  changed retVec@@ -1113,7 +1119,7 @@   go tcm (coreView1 tcm -> Just ty') = go tcm ty'   go tcm (tyView -> TyConApp vecTcNm _)     | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec     , [nilCon,consCon] <- tyConDataCons vecTc     = do       -- Get data constructors of 'Int'@@ -1222,7 +1228,7 @@   go tcm (coreView1 tcm -> Just ty') = go tcm ty'   go tcm (tyView -> TyConApp vecTcNm _)     | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm-    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , nameOcc vecTcNm == showt ''Vec     , [_nilCon,consCon] <- tyConDataCons vecTc     = do       -- Get data constructors of 'Int'@@ -1275,7 +1281,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc) <- UniqMap.lookup vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , nameOcc vecTcNm == showt ''Vec       , [_,consCon]  <- tyConDataCons vecTc       = do uniqs0 <- Lens.use uniqSupply            let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)@@ -1326,7 +1332,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp treeTcNm _)       | (Just treeTc) <- UniqMap.lookup treeTcNm tcm-      , nameOcc treeTcNm == "Clash.Sized.RTree.RTree"+      , nameOcc treeTcNm == showt ''RTree       , [lrCon,brCon] <- tyConDataCons treeTc       = do uniqs0 <- Lens.use uniqSupply            let (uniqs1,(vars,elems)) = extractTElems uniqs0 inScope lrCon brCon aTy 'T' n arg@@ -1367,7 +1373,7 @@     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp treeTcNm _)       | (Just treeTc) <- UniqMap.lookup treeTcNm tcm-      , nameOcc treeTcNm == "Clash.Sized.RTree.RTree"+      , nameOcc treeTcNm == showt ''RTree       , [lrCon,brCon] <- tyConDataCons treeTc       = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg)         in  changed retVec

@@ -74,10 +74,13 @@   conSpec   where     etaTL              = apply "etaTL" etaExpansionTL !-> topdownR (apply "applicationPropagation" appProp)-    inlineAndPropagate = repeatR (topdownR (applyMany transPropagateAndInline) >-> inlineNR)+    -- The outer repeatR is still needed: inlineNR is a full traversal whose+    -- results can only be processed by re-running the top-down bundle from the+    -- new root.+    inlineAndPropagate = repeatR (topdownFixR (applyMany transPropagateAndInline) >-> inlineNR)     spec               = bottomupR (applyMany specTransformations)-    caseFlattening     = repeatR (topdownR (apply "caseFlat" caseFlat))-    dec                = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))+    caseFlattening     = topdownFixR (apply "caseFlat" caseFlat)+    dec                = topdownFixR (apply "DEC" disjointExpressionConsolidation)     conSpec            = bottomupR  ((apply "appPropCS" appProp !->                                      bottomupR (apply "constantSpec" constantSpec)) >-!                                      apply "constantSpec" constantSpec)@@ -90,7 +93,7 @@       , ("caseCase"              , caseCase             )       , ("caseCon"               , caseCon              )       , ("elimExistentials"      , elimExistentials     )-      , ("caseElemNonReachable"  , caseElemNonReachable )+      , ("caseEliminateNonReachable"  , caseEliminateNonReachable )       , ("removeUnusedExpr"      , removeUnusedExpr     )       -- These transformations can safely be applied in a top-down traversal as       -- they themselves check whether the to-be-inlined binder is recursive or not.

@@ -28,6 +28,7 @@ import qualified Data.Text.Extra as Text (showt) import GHC.Stack (HasCallStack) +import Clash.Explicit.SimIO (SimIO) import Clash.Signal.Internal (Signal(..))  import Clash.Core.DataCon (DataCon(..))@@ -183,7 +184,7 @@   -> Bool isSimIOTy tcm ty = case tyView (coreView tcm ty) of   TyConApp tcNm args-    | nameOcc tcNm == "Clash.Explicit.SimIO.SimIO"+    | nameOcc tcNm == Text.showt ''SimIO     -> True     | nameOcc tcNm == "GHC.Prim.(#,#)"     , [_,_,st,_] <- args

@@ -19,7 +19,7 @@ module Clash.Normalize.Transformations.Case   ( caseCase   , caseCon-  , caseElemNonReachable+  , caseEliminateNonReachable   , caseFlat   , caseLet   , caseOneAlt@@ -461,8 +461,8 @@ -- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore -- unreachable. Additional information can be found at: -- https://github.com/clash-lang/clash-compiler/pull/465-caseElemNonReachable :: HasCallStack => NormRewrite-caseElemNonReachable _ case0@(Case scrut altsTy alts0) = do+caseEliminateNonReachable :: HasCallStack => NormRewrite+caseEliminateNonReachable _ case0@(Case scrut altsTy alts0) = do   tcm <- Lens.view tcCache    let (altsAbsurd, altsOther) = List.partition (isAbsurdPat tcm . fst) alts0@@ -470,8 +470,8 @@     [] -> return case0     _  -> changed =<< caseOneAlt (Case scrut altsTy altsOther) -caseElemNonReachable _ e = return e-{-# SCC caseElemNonReachable #-}+caseEliminateNonReachable _ e = return e+{-# SCC caseEliminateNonReachable #-}  -- | Flatten ridiculous case-statements generated by GHC --

@@ -54,9 +54,9 @@   , collectTicks, isLambdaBodyCtx, isTickCtx, mkApps, mkLams, mkTicks, Bind(..)   , partitionTicks, stripAllTicks) import Clash.Core.TermInfo (isCon, isLet, isLocalVar, isTick)-import Clash.Core.TyCon (tyConDataCons)+import Clash.Core.TyCon (TyConMap, tyConDataCons) import Clash.Core.Type-  (Type(..), TypeView(..), normalizeType+  (Type(..), TypeView(..), isClassTy, normalizeType   , splitFunForallTy, tyView) import Clash.Core.Util (inverseTopSortLetBindings, mkVec, tyNatSize) import Clash.Core.Var (isGlobalId)@@ -329,14 +329,19 @@         else           -- Check whether all arguments to the data constructor are projections           ---          and (zipWith (eqDat v1) (map pure [0..]) (Either.lefts args'))+          and (zipWith (eqDat tcm v1) (map pure [0..]) (Either.lefts args'))     eqArg _ _ _       = False      -- Recursively check whether a term /e/ is semantically equal to some variable /v/.-    -- Currently it can only assert equality when /e/ is  syntactically equal-    -- to /v/, or is constructed out of projections of /v/, importantly:+    -- Currently it can only assert equality when /e/:     --+    --   * is syntactically equal to /v/; or+    --   * is constructed out of projections of /v/; or+    --   * is constructed out of type-equal class dictionaries+    --+    -- or a mix of these.+    --     -- [Note: Breaks on constants and predetermined equality]     -- This function currently breaks if:     --@@ -350,13 +355,18 @@     --     always be the same, it might replace the (semantically equal to 'x')     --     construction of `y` with `(fst x, fst x)`.     ---    eqDat :: Term -> [Int] -> Term -> Bool-    eqDat v fTrace (collectArgs -> (Data _, args)) =-      and (zipWith (eqDat v) (map (:fTrace) [0..]) (Either.lefts args))-    eqDat v1 fTrace v2 =+    eqDat :: TyConMap -> Term -> [Int] -> Term -> Bool+    eqDat tcm v fTrace (collectArgs -> (Data _, args)) =+      and (zipWith (eqDat tcm v) (map (:fTrace) [0..]) (Either.lefts args))+    eqDat tcm v1 fTrace v2 =       case stripProjection (reverse fTrace) v1 v2 of         Just [] -> True-        _ -> False+        -- A class dictionary subfield is uniquely determined by its type, so we+        -- don't require it to be projected from the exact corresponding field.+        -- GHC routinely shares such dictionaries (e.g. the @KnownDomain@ inside+        -- a @HiddenClockResetEnable@) via CSE, projecting them from a different+        -- but type-equal field of the target than the one being reconstructed.+        _ -> isClassTy tcm (inferCoreTypeOf tcm v2)      stripProjection :: [Int] -> Term -> Term -> Maybe [Int]     stripProjection fTrace0 vTarget0 (Case v _ [(DataPat _ _ xs, r)]) = do

@@ -1,6 +1,6 @@ {-|   Copyright  :  (C) 2012-2016, University of Twente-                         2021, QBayLogic B.V.+                    2021-2026, QBayLogic B.V.   License    :  BSD2 (see the file LICENSE)   Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> @@ -16,6 +16,7 @@   , bottomupR   , repeatR   , topdownR+  , topdownFixR   ) where  import           Control.DeepSeq             (deepseq)@@ -117,6 +118,69 @@ topdownR :: Rewrite m -> Rewrite m -- See Note [topdown repeatR] topdownR r = repeatR r >-> allR (topdownR r)++{-+Note [topdownFixR]+~~~~~~~~~~~~~~~~~~+'topdownFixR r' is an optimized alternative to some uses of+'repeatR (topdownR r)'. It repeats 'r' top-down, but when a child changes it+only rechecks the ancestors of that child instead of restarting traversal from+the root.++For example, suppose 'r' can rewrite both:++> let x = True in x++to:++> True++and:++> case True of { True -> a; False -> b }++to:++> a++When traversing:++> h (case (let x = True in x) of { True -> a; False -> b })++'topdownFixR r' first cannot rewrite the 'case', so it descends into the+scrutinee. Rewriting the scrutinee exposes a new redex at the parent 'case', so+the parent is checked again immediately and rewritten to 'a'. That change then+bubbles up to 'h a'. With 'repeatR (topdownR r)' the same result is reached by+starting another complete traversal from 'h'.++Only use 'topdownFixR' as a replacement for 'repeatR (topdownR r)' when 'r' is+local and context-stable: it should fire or fail based on the current node, and+the relevant parts of 'TransformContext' should not change when sibling+subtrees are rewritten. Rewrites that inspect let-bound context whose binding+terms may have changed, for example through 'whnfRW', still need an outer+repeat or a normal repeated top-down traversal.+-}++-- | Apply a transformation in a repeated top-down traversal.+--+-- Optimized for local, context-stable transformations. See Note [topdownFixR].+topdownFixR :: Rewrite m -> Rewrite m+topdownFixR r = go True+ where+  go tryParent ctx term = do+    term1 <-+      if tryParent+        then repeatR r ctx term+        else pure term+    (term2, Monoid.getAny -> childChanged) <- Writer.listen (allR (go True) ctx term1)+    if childChanged+      then do+        (term3, Monoid.getAny -> parentChanged) <- Writer.listen (repeatR r ctx term2)+        if parentChanged+          then go False ctx term3+          else return term3+      else return term2+{-# INLINE topdownFixR #-}  -- | Apply a transformation in a bottomup traversal bottomupR :: Monad m => Transform m -> Transform m

@@ -25,6 +25,7 @@ import Control.Lens                          (Lens', use, (.=)) import qualified Control.Lens as Lens import Control.Monad.Fix                     (MonadFix)+import Control.Monad.IO.Class                (MonadIO) import Control.Monad.State.Strict            (State) import Control.Monad.Reader                  (MonadReader (..)) import Control.Monad.State                   (MonadState (..))@@ -169,6 +170,7 @@     , Functor     , Monad     , MonadFix+    , MonadIO     , MonadState (RewriteState extra)     , MonadWriter Any     , MonadReader RewriteEnv

@@ -29,6 +29,7 @@ import           Control.Lens ((%=), (+=), (^.)) import qualified Control.Lens                as Lens import qualified Control.Monad               as Monad+import           Control.Monad.IO.Class      (liftIO) import qualified Control.Monad.State.Strict  as State import qualified Control.Monad.Trans.RWS.CPS as RWS import qualified Control.Monad.Writer        as Writer@@ -46,7 +47,6 @@ import qualified Data.Set.Lens               as Lens import           Data.Text                   (Text) import qualified Data.Text                   as Text-import           System.IO.Unsafe            (unsafePerformIO) import           Data.Binary                 (encode) import qualified Data.ByteString             as BS import qualified Data.ByteString.Lazy        as BL@@ -152,17 +152,16 @@   let rewriteHistFile = dbg_historyFile opts   Monad.when (isJust rewriteHistFile && hasChanged) $ do     (curBndr, _) <- Lens.use curFun-    let !_ = unsafePerformIO-             $ BS.appendFile (fromJust rewriteHistFile)-             $ BL.toStrict-             $ encode RewriteStep-                 { t_ctx    = tfContext ctx-                 , t_name   = s-                 , t_bndrS  = showPpr (varName curBndr)-                 , t_before = expr0-                 , t_after  = expr1-                 }-    return ()+    liftIO+      $ BS.appendFile (fromJust rewriteHistFile)+      $ BL.toStrict+      $ encode RewriteStep+          { t_ctx    = tfContext ctx+          , t_name   = s+          , t_bndrS  = showPpr (varName curBndr)+          , t_before = expr0+          , t_after  = expr1+          }    if isDebugging opts     then applyDebug ctx s expr0 hasChanged expr1

@@ -40,13 +40,16 @@ -}  {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-}  -- TODO: only export the @i@ quasiquoter when `ghcide` stops type-checking -- expanded quasiquote splices module Clash.Util.Interpolate (i, format, toString) where -import           Language.Haskell.Meta.Parse (parseExp)+-- This module also exists in @ghc-hs-meta@, see+-- https://github.com/clash-lang/clash-compiler/pull/3366+import "haskell-src-meta" Language.Haskell.Meta.Parse (parseExp) import           Language.Haskell.TH.Lib     (appE, varE) import           Language.Haskell.TH.Quote   (QuasiQuoter(..)) import           Language.Haskell.TH.Syntax  (Q, Exp)@@ -140,7 +143,9 @@     maxLength = 80      go :: Int -> [Node] -> [Node] -> [[Node]]-    go accLen acc goNodes | accLen > maxLength = reverse acc : go 0 [] goNodes+    -- Only break when there's still content to put on the next line; otherwise+    -- we'd emit a trailing empty line. See issue #2753.+    go accLen acc goNodes@(_:_) | accLen > maxLength = reverse acc : go 0 [] goNodes     go accLen acc (l@(Literal s):goNodes) = go (accLen + length s) (l:acc) goNodes     go accLen acc (e@(Expression s):goNodes) = go (accLen + length s) (e:acc) goNodes     go _accLen acc [] = [reverse acc]

@@ -62,10 +62,20 @@     <*> Q.elements [False, True]     <*> coerce @(Q.Gen (Maybe ArbitraryText)) Q.arbitrary +genDebugSubHashes :: Q.Gen DebugSubHashes+genDebugSubHashes =+  DebugSubHashes+    <$> genDigest+    <*> genDigest+    <*> genDigest+    <*> genDigest+    <*> genDigest+ genManifest :: Q.Gen Manifest genManifest =   Manifest     <$> genDigest -- hash+    <*> Q.oneof [pure Nothing, Just <$> genDebugSubHashes] -- __debug_hash     <*> Q.arbitrary -- flags     <*> Q.listOf genPort -- ports     <*> coerce @(Q.Gen [ArbitraryText]) @(Q.Gen [Text]) Q.arbitrary -- comp names

@@ -12,7 +12,7 @@ import Test.Tasty import Test.Tasty.HUnit -test1, test2, test3, test4, test5, test6, test7, test8, test9 :: String+test1, test2, test3, test4, test5, test6, test7, test8, test9, test10 :: String test1 = [I.i| Simple |] test2 = [I.i|   Single line@@ -46,6 +46,14 @@   looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong word |] +-- Regression test for issue #2753: a paragraph that wraps onto multiple lines+-- followed by a blank line was emitting an extra blank line.+test10 = [I.i|+  Clash has known issues on 9.4.8 on your current OS. While not completely preventing the compiler from working, we recommend switching to another GHC version. Symptoms:++  After.+|]+ data SomeRecord = SomeRecord { getField :: Int } someRecord :: SomeRecord someRecord = SomeRecord 5@@ -69,4 +77,9 @@     , testCase "test7" $ test7 @?= ("The big test:\n\n" ++ test5)     , testCase "test8" $ test8 @?= "looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong \nword"     , testCase "test9" $ test9 @?= "\\42"+    , testCase "test10" $ test10 @?=+        "Clash has known issues on 9.4.8 on your current OS. While not completely preventing \n\+        \the compiler from working, we recommend switching to another GHC version. Symptoms:\n\+        \\n\+        \After."     ]