diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.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, diff --git a/prims/vhdl/GHC_Num_Integer.primitives.yaml b/prims/vhdl/GHC_Num_Integer.primitives.yaml --- a/prims/vhdl/GHC_Num_Integer.primitives.yaml +++ b/prims/vhdl/GHC_Num_Integer.primitives.yaml @@ -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 diff --git a/src/Clash/Annotations/TopEntity/Extra.hs b/src/Clash/Annotations/TopEntity/Extra.hs --- a/src/Clash/Annotations/TopEntity/Extra.hs +++ b/src/Clash/Annotations/TopEntity/Extra.hs @@ -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 diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs --- a/src/Clash/Backend/VHDL.hs +++ b/src/Clash/Backend/VHDL.hs @@ -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 diff --git a/src/Clash/Core/EqSolver.hs b/src/Clash/Core/EqSolver.hs --- a/src/Clash/Core/EqSolver.hs +++ b/src/Clash/Core/EqSolver.hs @@ -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 diff --git a/src/Clash/Core/Literal.hs b/src/Clash/Core/Literal.hs --- a/src/Clash/Core/Literal.hs +++ b/src/Clash/Core/Literal.hs @@ -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 diff --git a/src/Clash/Core/Pretty.hs b/src/Clash/Core/Pretty.hs --- a/src/Clash/Core/Pretty.hs +++ b/src/Clash/Core/Pretty.hs @@ -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 diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs --- a/src/Clash/Core/Type.hs +++ b/src/Clash/Core/Type.hs @@ -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 diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -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))) diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -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 diff --git a/src/Clash/Driver/Manifest.hs b/src/Clash/Driver/Manifest.hs --- a/src/Clash/Driver/Manifest.hs +++ b/src/Clash/Driver/Manifest.hs @@ -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} diff --git a/src/Clash/Driver/Types.hs b/src/Clash/Driver/Types.hs --- a/src/Clash/Driver/Types.hs +++ b/src/Clash/Driver/Types.hs @@ -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. diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs --- a/src/Clash/Netlist/BlackBox.hs +++ b/src/Clash/Netlist/BlackBox.hs @@ -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. diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -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 diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -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 diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs --- a/src/Clash/Normalize.hs +++ b/src/Clash/Normalize.hs @@ -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)) diff --git a/src/Clash/Normalize/PrimitiveReductions.hs b/src/Clash/Normalize/PrimitiveReductions.hs --- a/src/Clash/Normalize/PrimitiveReductions.hs +++ b/src/Clash/Normalize/PrimitiveReductions.hs @@ -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 diff --git a/src/Clash/Normalize/Strategy.hs b/src/Clash/Normalize/Strategy.hs --- a/src/Clash/Normalize/Strategy.hs +++ b/src/Clash/Normalize/Strategy.hs @@ -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. diff --git a/src/Clash/Normalize/Transformations/ANF.hs b/src/Clash/Normalize/Transformations/ANF.hs --- a/src/Clash/Normalize/Transformations/ANF.hs +++ b/src/Clash/Normalize/Transformations/ANF.hs @@ -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 diff --git a/src/Clash/Normalize/Transformations/Case.hs b/src/Clash/Normalize/Transformations/Case.hs --- a/src/Clash/Normalize/Transformations/Case.hs +++ b/src/Clash/Normalize/Transformations/Case.hs @@ -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 -- diff --git a/src/Clash/Normalize/Transformations/Letrec.hs b/src/Clash/Normalize/Transformations/Letrec.hs --- a/src/Clash/Normalize/Transformations/Letrec.hs +++ b/src/Clash/Normalize/Transformations/Letrec.hs @@ -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 diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs --- a/src/Clash/Rewrite/Combinators.hs +++ b/src/Clash/Rewrite/Combinators.hs @@ -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. @@ -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 diff --git a/src/Clash/Rewrite/Types.hs b/src/Clash/Rewrite/Types.hs --- a/src/Clash/Rewrite/Types.hs +++ b/src/Clash/Rewrite/Types.hs @@ -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 diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -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 diff --git a/src/Clash/Util/Interpolate.hs b/src/Clash/Util/Interpolate.hs --- a/src/Clash/Util/Interpolate.hs +++ b/src/Clash/Util/Interpolate.hs @@ -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] diff --git a/tests/Clash/Tests/Driver/Manifest.hs b/tests/Clash/Tests/Driver/Manifest.hs --- a/tests/Clash/Tests/Driver/Manifest.hs +++ b/tests/Clash/Tests/Driver/Manifest.hs @@ -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 diff --git a/tests/Clash/Tests/Util/Interpolate.hs b/tests/Clash/Tests/Util/Interpolate.hs --- a/tests/Clash/Tests/Util/Interpolate.hs +++ b/tests/Clash/Tests/Util/Interpolate.hs @@ -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." ]