clash-ghc 1.10.0 → 1.10.1
raw patch · 9 files changed
+447/−329 lines, 9 filesdep −data-binary-ieee754dep ~clash-libdep ~clash-preludedep ~string-interpolatePVP ok
version bump matches the API change (PVP)
Dependencies removed: data-binary-ieee754
Dependency ranges changed: clash-lib, clash-prelude, string-interpolate, time
API changes (from Hackage documentation)
Files
- CHANGELOG.md +67/−0
- cbits/PosixSource.h +0/−41
- cbits/hschooks.c +0/−61
- clash-ghc.cabal +27/−19
- src-ghc/Clash/GHC/ClashFlags.hs +4/−0
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +168/−159
- src-ghc/Clash/GHC/GHC2Core.hs +3/−3
- src-ghc/Clash/GHC/GenerateBindings.hs +100/−34
- src-ghc/Clash/GHC/LoadModules.hs +78/−12
CHANGELOG.md view
@@ -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:
− cbits/PosixSource.h
@@ -1,41 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2005- *- * Include this file into sources which should not need any non-Posix services.- * That includes most RTS C sources.- * ---------------------------------------------------------------------------*/--#ifndef POSIXSOURCE_H-#define POSIXSOURCE_H--#include <ghcplatform.h>--/* We aim for C99 so we need to define following two defines in a consistent way- with what POSIX/XOPEN provide for C99. Some OSes are particularly picky about- the right versions defined here, e.g. Solaris- We also settle on lowest version of POSIX/XOPEN needed for proper C99 support- here which is POSIX.1-2001 compilation and Open Group Technical Standard,- Issue 6 (XPG6). XPG6 itself is a result of the merge of X/Open and POSIX- specification. It is also referred as IEEE Std. 1003.1-2001 or ISO/IEC- 9945:2002 or UNIX 03 and SUSv3.- Please also see trac ticket #11757 for more information about switch- to C99/C11.-- However, the use of `strnlen`, which is strictly speaking only available in- IEEE Std 1003.1-2008 (XPG7), requires lifting the bounds, to be able to- compile ghc on systems that are strict about enforcing the standard, e.g.- Apples mobile platforms.-- Oracle's Solaris 11 supports only up to XPG6, hence the ifdef.- */--#if defined(solaris2_HOST_OS)-#define _POSIX_C_SOURCE 200112L-#define _XOPEN_SOURCE 600-#else-#define _POSIX_C_SOURCE 200809L-#define _XOPEN_SOURCE 700-#endif--#endif /* POSIXSOURCE_H */
− cbits/hschooks.c
@@ -1,61 +0,0 @@-/*-These routines customise the error messages-for various bits of the RTS. They are linked-in instead of the defaults.-*/--#include "PosixSource.h"--/*- * This should be linked against Rts.h from the compiler which is compiling us.- * For instance, if we are compiling this file to produce the stage1 compiler,- * we should use Rts.h from stage0.- */-#include "Rts.h"--#include "HsFFI.h"--#include <string.h>-#include <stdbool.h>--#ifdef HAVE_UNISTD_H-#include <unistd.h>-#endif--void-initGCStatistics(void)-{- /* Workaround for #8754: if the GC stats aren't enabled because the- compiler couldn't use -Bsymbolic to link the default hooks, then- initialize them sensibly. See Note [-Bsymbolic and hooks] in- Main.hs. */- if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) {- RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;- }-}--void-defaultsHook (void)-{- // This helps particularly with large compiles, but didn't work- // very well with earlier GHCs because it caused large amounts of- // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().- RtsFlags.GcFlags.heapSizeSuggestionAuto = true;-- RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_);-- initGCStatistics();-- // See #3408: the default idle GC time of 0.3s is too short on- // Windows where we receive console events once per second or so.- RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5);-}--void-StackOverflowHook (StgWord stack_size) /* in bytes */-{- fprintf(stderr,- "GHC stack-space overflow: current limit is %zu bytes.\n"- "Use the `-K<size>' option to increase it.\n",- (size_t) stack_size);-}
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.10.0+Version: 1.10.1 Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its@@ -39,7 +39,8 @@ Maintainer: QBayLogic B.V. <devops@qbaylogic.com> Copyright: Copyright © 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd,- 2017-2019, QBayLogic B.V., Google Inc.+ 2017-2019, Google Inc.,+ 2017-2026, QBayLogic B.V. Category: Hardware Build-type: Simple tested-with: GHC == 9.6.7,@@ -49,8 +50,7 @@ Extra-source-files: README.md, CHANGELOG.md,- LICENSE_GHC,- cbits/PosixSource.h+ LICENSE_GHC source-repository head type: git@@ -78,24 +78,36 @@ executable clash Main-Is: src-ghc/Batch.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall -Wcompat -threaded -rtsopts+ GHC-Options:+ -- -T: Workaround for GHC #8754: if the GC stats aren't enabled because+ -- the -- compiler couldn't use -Bsymbolic to link the default hooks, then+ -- initialize them sensibly.+ --+ -- -I5: See GHC #3408: the default idle GC time of 0.3s is too short on+ -- Windows where we receive console events once per second or so.+ --+ -- -H and -K512M: Trade slight memory increase for better performance in+ -- large designs.+ "-with-rtsopts=-K512M -H -I5 -T"+ -Wall+ -Wcompat+ -threaded+ -rtsopts if flag(dynamic) GHC-Options: -dynamic- -- Note that multiple -with-rtsopts are not cumulative, so we can't add the- -- common RTS options in the unconditional GHC-Options if arch(x86_64) && flag(workaround-ghc-mmap-crash)- GHC-Options: "-with-rtsopts=-A128m -xm20000000"- else- GHC-Options: -with-rtsopts=-A128m+ GHC-Options: "-with-rtsopts=-K512M -H -I5 -T -xm20000000" extra-libraries: pthread default-language: Haskell2010 executable clashi Main-Is: src-ghc/Interactive.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall -Wcompat -rtsopts -with-rtsopts=-A128m+ GHC-Options: -Wall -Wcompat -rtsopts "-with-rtsopts=-K512M -H -I5 -T" if flag(dynamic) GHC-Options: -dynamic+ if arch(x86_64) && flag(workaround-ghc-mmap-crash)+ GHC-Options: "-with-rtsopts=-K512M -H -I5 -T -xm20000000" extra-libraries: pthread default-language: Haskell2010 @@ -149,7 +161,6 @@ bytestring >= 0.9 && < 0.13, Cabal, containers >= 0.5.4.0 && < 0.9,- data-binary-ieee754 >= 0.4.4 && < 0.6, directory >= 1.2 && < 1.4, extra >= 1.6 && < 1.9, filepath >= 1.3 && < 1.6,@@ -162,13 +173,13 @@ text >= 1.2.2 && < 2.2, transformers >= 0.5.2.0 && < 0.7, unordered-containers >= 0.2.1.0 && < 0.3,- clash-lib == 1.10.0,- clash-prelude == 1.10.0,+ clash-lib == 1.10.1,+ clash-prelude == 1.10.1, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, deepseq >= 1.3.0.2 && < 1.6,- time >= 1.4.0.1 && < 1.15,+ time >= 1.4.0.1 && < 1.17, ghc >= 9.6.0 && < 9.13, ghc-bignum >= 1.0 && < 1.4, ghc-boot >= 9.6.0 && < 9.13,@@ -177,7 +188,7 @@ uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0, primitive >= 0.5.0.1 && < 1.0,- string-interpolate ^>= 0.3,+ string-interpolate >= 0.3 && < 1.1, template-haskell >= 2.8.0.0 && < 2.24, utf8-string >= 1.0.0.0 && < 1.1.0.0, vector >= 0.11 && < 1.0,@@ -191,9 +202,6 @@ Build-Depends: Win32 >= 2.3.1 && < 2.15 else Build-Depends: unix >= 2.7.1 && < 2.9-- Include-dirs: cbits- C-Sources: cbits/hschooks.c Autogen-Modules: Paths_clash_ghc
src-ghc/Clash/GHC/ClashFlags.hs view
@@ -87,6 +87,7 @@ , defFlag "fclash-timescale-precision" $ SepArg (setTimescalePrecision r) , defFlag "fclash-ignore-broken-ghcs" $ NoArg (liftEwM (setIgnoreBrokenGhcs r)) , defFlag "fclash-no-concurrent-topentity-compilation" $ NoArg (liftEwM (setNoConcurrentTopEntities r))+ , defFlag "fclash-debug-manifest-hash" $ NoArg (liftEwM (setDebugManifestHash r)) ] -- | Print deprecated flag warning@@ -341,3 +342,6 @@ setNoConcurrentTopEntities :: IORef ClashOpts -> IO () setNoConcurrentTopEntities r = modifyIORef r (\c -> c { opt_concurrentTopEntities = False })++setDebugManifestHash :: IORef ClashOpts -> IO ()+setDebugManifestHash r = modifyIORef r (\c -> c { opt_debugManifestHash = True })
src-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -33,12 +33,11 @@ ) where import Control.DeepSeq (force)-import Control.Exception (ArithException(..), Exception, tryJust, evaluate)+import Control.Exception (ArithException(..), ErrorCall, Exception, tryJust, evaluate) import qualified Control.Lens as Lens import Control.Monad.State.Strict (State, MonadState) import qualified Control.Monad.State.Strict as State import Control.Monad.Trans.Except (runExcept)-import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, wordToFloat) import Data.Bits import qualified Data.ByteString.Internal as BS import Data.Char (chr,ord)@@ -350,7 +349,7 @@ -> reduce (boolToIntLiteral (i <= j)) $(namePat 'GHC.Prim.chr#) | [i] <- intLiterals' args- -> reduce (charToCharLiteral (chr $ fromInteger i))+ -> reduce (catchErrorCall (charToCharLiteral (chr $ fromInteger i))) $(namePat 'GHC.Prim.int2Word#) | [Lit (IntLiteral i)] <- args@@ -358,17 +357,17 @@ $(namePat 'GHC.Prim.int2Float#) | [Lit (IntLiteral i)] <- args- -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i+ -> reduce . Literal . FloatLiteral . castFloatToWord32 $ fromInteger i $(namePat 'GHC.Prim.int2Double#) | [Lit (IntLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i+ -> reduce . Literal . DoubleLiteral . castDoubleToWord64 $ fromInteger i $(namePat 'GHC.Prim.word2Float#) | [Lit (WordLiteral i)] <- args- -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i+ -> reduce . Literal . FloatLiteral . castFloatToWord32 $ fromInteger i $(namePat 'GHC.Prim.word2Double#) | [Lit (WordLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i+ -> reduce . Literal . DoubleLiteral . castDoubleToWord64 $ fromInteger i $(namePat 'GHC.Prim.uncheckedIShiftL#) | [ Lit (IntLiteral i)@@ -596,22 +595,21 @@ -> reduce r $(namePat 'GHC.Prim.timesInt8#) | Just r <- liftI8 timesInt8# args -> reduce r- $(namePat 'GHC.Prim.quotInt8#) | Just r <- liftI8 quotInt8# args- -> reduce r- $(namePat 'GHC.Prim.remInt8#) | Just r <- liftI8 remInt8# args- -> reduce r+ $(namePat 'GHC.Prim.quotInt8#) | [i, j] <- int8Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int8Literal (toInteger (fromInteger i `quot` fromInteger j :: Int8))))+ $(namePat 'GHC.Prim.remInt8#) | [i, j] <- int8Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int8Literal (toInteger (fromInteger i `rem` fromInteger j :: Int8)))) $(namePat 'GHC.Prim.quotRemInt8#) | [i, j] <- int8Literals' args , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , (Just tupTc) <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let !(I8# a) = fromInteger i- !(I8# b) = fromInteger j- !(# q, r #) = quotRemInt8# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Int8Literal (toInteger (I8# q))))- , Left (Literal (Int8Literal (toInteger (I8# r))))])+ -> let (q,r) = quotRem (fromInteger i :: Int8) (fromInteger j)+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal (Int8Literal (toInteger q)))+ , Left $ catchDivByZero (Literal (Int8Literal (toInteger r)))]) $(namePat 'GHC.Prim.uncheckedShiftLInt8#) | Just r <- liftI8I uncheckedShiftLInt8# args -> reduce r $(namePat 'GHC.Prim.uncheckedShiftRAInt8#) | Just r <- liftI8I uncheckedShiftRAInt8# args@@ -653,22 +651,21 @@ -> reduce r $(namePat 'GHC.Prim.timesInt16#) | Just r <- liftI16 timesInt16# args -> reduce r- $(namePat 'GHC.Prim.quotInt16#) | Just r <- liftI16 quotInt16# args- -> reduce r- $(namePat 'GHC.Prim.remInt16#) | Just r <- liftI16 remInt16# args- -> reduce r+ $(namePat 'GHC.Prim.quotInt16#) | [i, j] <- int16Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int16Literal (toInteger (fromInteger i `quot` fromInteger j :: Int16))))+ $(namePat 'GHC.Prim.remInt16#) | [i, j] <- int16Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int16Literal (toInteger (fromInteger i `rem` fromInteger j :: Int16)))) $(namePat 'GHC.Prim.quotRemInt16#) | [i, j] <- int16Literals' args , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , (Just tupTc) <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let !(I16# a) = fromInteger i- !(I16# b) = fromInteger j- !(# q, r #) = quotRemInt16# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Int16Literal (toInteger (I16# q))))- , Left (Literal (Int16Literal (toInteger (I16# r))))])+ -> let (q,r) = quotRem (fromInteger i :: Int16) (fromInteger j)+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal (Int16Literal (toInteger q)))+ , Left $ catchDivByZero (Literal (Int16Literal (toInteger r)))]) $(namePat 'GHC.Prim.uncheckedShiftLInt16#) | Just r <- liftI16I uncheckedShiftLInt16# args -> reduce r $(namePat 'GHC.Prim.uncheckedShiftRAInt16#) | Just r <- liftI16I uncheckedShiftRAInt16# args@@ -710,22 +707,21 @@ -> reduce r $(namePat 'GHC.Prim.timesInt32#) | Just r <- liftI32 timesInt32# args -> reduce r- $(namePat 'GHC.Prim.quotInt32#) | Just r <- liftI32 quotInt32# args- -> reduce r- $(namePat 'GHC.Prim.remInt32#) | Just r <- liftI32 remInt32# args- -> reduce r+ $(namePat 'GHC.Prim.quotInt32#) | [i, j] <- int32Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int32Literal (toInteger (fromInteger i `quot` fromInteger j :: Int32))))+ $(namePat 'GHC.Prim.remInt32#) | [i, j] <- int32Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int32Literal (toInteger (fromInteger i `rem` fromInteger j :: Int32)))) $(namePat 'GHC.Prim.quotRemInt32#) | [i, j] <- int32Literals' args , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , (Just tupTc) <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let !(I32# a) = fromInteger i- !(I32# b) = fromInteger j- !(# q, r #) = quotRemInt32# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Int32Literal (toInteger (I32# q))))- , Left (Literal (Int32Literal (toInteger (I32# r))))])+ -> let (q,r) = quotRem (fromInteger i :: Int32) (fromInteger j)+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal (Int32Literal (toInteger q)))+ , Left $ catchDivByZero (Literal (Int32Literal (toInteger r)))]) $(namePat 'GHC.Prim.uncheckedShiftLInt32#) | Just r <- liftI32I uncheckedShiftLInt32# args -> reduce r $(namePat 'GHC.Prim.uncheckedShiftRAInt32#) | Just r <- liftI32I uncheckedShiftRAInt32# args@@ -765,10 +761,12 @@ -> reduce r $(namePat 'GHC.Prim.timesInt64#) | Just r <- liftI64 timesInt64# args -> reduce r- $(namePat 'GHC.Prim.quotInt64#) | Just r <- liftI64 quotInt64# args- -> reduce r- $(namePat 'GHC.Prim.remInt64#) | Just r <- liftI64 remInt64# args- -> reduce r+ $(namePat 'GHC.Prim.quotInt64#) | [i, j] <- int64Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int64Literal (toInteger (fromInteger i `quot` fromInteger j :: Int64))))+ $(namePat 'GHC.Prim.remInt64#) | [i, j] <- int64Literals' args+ -> reduce $ catchDivByZero+ (Literal (Int64Literal (toInteger (fromInteger i `rem` fromInteger j :: Int64)))) $(namePat 'GHC.Prim.uncheckedIShiftL64#) | Just r <- liftI64I uncheckedIShiftL64# args -> reduce r $(namePat 'GHC.Prim.uncheckedIShiftRA64#) | Just r <- liftI64I uncheckedIShiftRA64# args@@ -806,22 +804,21 @@ -> reduce r $(namePat 'GHC.Prim.timesWord8#) | Just r <- liftW8 timesWord8# args -> reduce r- $(namePat 'GHC.Prim.quotWord8#) | Just r <- liftW8 quotWord8# args- -> reduce r- $(namePat 'GHC.Prim.remWord8#) | Just r <- liftW8 remWord8# args- -> reduce r+ $(namePat 'GHC.Prim.quotWord8#) | [i, j] <- word8Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word8Literal (toInteger (fromInteger i `quot` fromInteger j :: Word8))))+ $(namePat 'GHC.Prim.remWord8#) | [i, j] <- word8Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word8Literal (toInteger (fromInteger i `rem` fromInteger j :: Word8)))) $(namePat 'GHC.Prim.quotRemWord8#) | [i, j] <- word8Literals' args , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , (Just tupTc) <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let !(W8# a) = fromInteger i- !(W8# b) = fromInteger j- !(# q, r #) = quotRemWord8# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Word8Literal (toInteger (W8# q))))- , Left (Literal (Word8Literal (toInteger (W8# r))))])+ -> let (q,r) = quotRem (fromInteger i :: Word8) (fromInteger j)+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal (Word8Literal (toInteger q)))+ , Left $ catchDivByZero (Literal (Word8Literal (toInteger r)))]) $(namePat 'GHC.Prim.andWord8#) | Just r <- liftW8 andWord8# args -> reduce r $(namePat 'GHC.Prim.orWord8#) | Just r <- liftW8 orWord8# args@@ -866,22 +863,21 @@ -> reduce r $(namePat 'GHC.Prim.timesWord16#) | Just r <- liftW16 timesWord16# args -> reduce r- $(namePat 'GHC.Prim.quotWord16#) | Just r <- liftW16 quotWord16# args- -> reduce r- $(namePat 'GHC.Prim.remWord16#) | Just r <- liftW16 remWord16# args- -> reduce r+ $(namePat 'GHC.Prim.quotWord16#) | [i, j] <- word16Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word16Literal (toInteger (fromInteger i `quot` fromInteger j :: Word16))))+ $(namePat 'GHC.Prim.remWord16#) | [i, j] <- word16Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word16Literal (toInteger (fromInteger i `rem` fromInteger j :: Word16)))) $(namePat 'GHC.Prim.quotRemWord16#) | [i, j] <- word16Literals' args , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , (Just tupTc) <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let !(W16# a) = fromInteger i- !(W16# b) = fromInteger j- !(# q, r #) = quotRemWord16# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Word16Literal (toInteger (W16# q))))- , Left (Literal (Word16Literal (toInteger (W16# r))))])+ -> let (q,r) = quotRem (fromInteger i :: Word16) (fromInteger j)+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal (Word16Literal (toInteger q)))+ , Left $ catchDivByZero (Literal (Word16Literal (toInteger r)))]) $(namePat 'GHC.Prim.andWord16#) | Just r <- liftW16 andWord16# args -> reduce r $(namePat 'GHC.Prim.orWord16#) | Just r <- liftW16 orWord16# args@@ -926,22 +922,21 @@ -> reduce r $(namePat 'GHC.Prim.timesWord32#) | Just r <- liftW32 timesWord32# args -> reduce r- $(namePat 'GHC.Prim.quotWord32#) | Just r <- liftW32 quotWord32# args- -> reduce r- $(namePat 'GHC.Prim.remWord32#) | Just r <- liftW32 remWord32# args- -> reduce r+ $(namePat 'GHC.Prim.quotWord32#) | [i, j] <- word32Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word32Literal (toInteger (fromInteger i `quot` fromInteger j :: Word32))))+ $(namePat 'GHC.Prim.remWord32#) | [i, j] <- word32Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word32Literal (toInteger (fromInteger i `rem` fromInteger j :: Word32)))) $(namePat 'GHC.Prim.quotRemWord32#) | [i, j] <- word32Literals' args , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , (Just tupTc) <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let !(W32# a) = fromInteger i- !(W32# b) = fromInteger j- !(# q, r #) = quotRemWord32# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Word32Literal (toInteger (W32# q))))- , Left (Literal (Word32Literal (toInteger (W32# r))))])+ -> let (q,r) = quotRem (fromInteger i :: Word32) (fromInteger j)+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal (Word32Literal (toInteger q)))+ , Left $ catchDivByZero (Literal (Word32Literal (toInteger r)))]) $(namePat 'GHC.Prim.andWord32#) | Just r <- liftW32 andWord32# args -> reduce r $(namePat 'GHC.Prim.orWord32#) | Just r <- liftW32 orWord32# args@@ -984,10 +979,12 @@ -> reduce r $(namePat 'GHC.Prim.timesWord64#) | Just r <- liftW64 timesWord64# args -> reduce r- $(namePat 'GHC.Prim.quotWord64#) | Just r <- liftW64 quotWord64# args- -> reduce r- $(namePat 'GHC.Prim.remWord64#) | Just r <- liftW64 remWord64# args- -> reduce r+ $(namePat 'GHC.Prim.quotWord64#) | [i, j] <- word64Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word64Literal (toInteger (fromInteger i `quot` fromInteger j :: Word64))))+ $(namePat 'GHC.Prim.remWord64#) | [i, j] <- word64Literals' args+ -> reduce $ catchDivByZero+ (Literal (Word64Literal (toInteger (fromInteger i `rem` fromInteger j :: Word64)))) $(namePat 'GHC.Prim.and64#) | Just r <- liftW64 and64# args -> reduce r $(namePat 'GHC.Prim.or64#) | Just r <- liftW64 or64# args@@ -1047,14 +1044,14 @@ -> reduce r $(namePat 'GHC.Prim.double2Int#) | [i] <- doubleLiterals' args- -> let !(D# a) = wordToDouble i+ -> let !(D# a) = castWord64ToDouble i r = double2Int# a in reduce . Literal . IntLiteral . toInteger $ I# r $(namePat 'GHC.Prim.double2Float#) | [Lit (DoubleLiteral d)] <- args- -> let !(D# a) = wordToDouble d+ -> let !(D# a) = castWord64ToDouble d r = double2Float# a- in reduce . Literal . FloatLiteral . floatToWord $ F# r+ in reduce . Literal . FloatLiteral . castFloatToWord32 $ F# r $(namePat 'GHC.Prim.expDouble#) | Just r <- liftDD expDouble# args -> reduce r@@ -1094,7 +1091,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = UniqMap.lookup tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(D# a) = wordToDouble i+ !(D# a) = castWord64ToDouble i !(# p, q, r, s #) = decodeDouble_2Int# a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -1107,7 +1104,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = UniqMap.lookup tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(D# a) = wordToDouble i+ !(D# a) = castWord64ToDouble i !(# p, q #) = decodeDouble_Int64# a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -1145,7 +1142,7 @@ -> reduce r $(namePat 'GHC.Prim.float2Int#) | [i] <- floatLiterals' args- -> let !(F# a) = wordToFloat i+ -> let !(F# a) = castWord32ToFloat i r = float2Int# a in reduce . Literal . IntLiteral . toInteger $ I# r @@ -1196,9 +1193,9 @@ -> reduce r $(namePat 'GHC.Prim.float2Double#) | [i] <- floatLiterals' args- -> let !(F# a) = wordToFloat i+ -> let !(F# a) = castWord32ToFloat i r = float2Double# a- in reduce . Literal . DoubleLiteral . doubleToWord $ D# r+ in reduce . Literal . DoubleLiteral . castDoubleToWord64 $ D# r $(namePat 'GHC.Prim.newByteArray#)@@ -1400,7 +1397,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = UniqMap.lookup tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(F# a) = wordToFloat i+ !(F# a) = castWord32ToFloat i !(# p, q #) = decodeFloat_Int# a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -1513,7 +1510,7 @@ _ -> Nothing $(namePat 'GHC.Classes.divInt#) | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `div` j))+ -> reduce (catchDivByZero (integerToIntLiteral (i `div` j))) -- modInt# :: Int# -> Int# -> Int# $(namePat 'GHC.Classes.modInt#)@@ -1537,12 +1534,12 @@ $(namePat 'GHC.Float.integerToFloat#) | [v] <- args , Just i <- integerLiteral v- -> reduce . Literal . FloatLiteral . floatToWord $ F# (integerToFloat# i)+ -> reduce . Literal . FloatLiteral . castFloatToWord32 $ F# (integerToFloat# i) $(namePat 'GHC.Float.integerToDouble#) | [v] <- args , Just i <- integerLiteral v- -> reduce . Literal . DoubleLiteral . doubleToWord $ D# (integerToDouble# i)+ -> reduce . Literal . DoubleLiteral . castDoubleToWord64 $ D# (integerToDouble# i) $(namePat 'GHC.Num.naturalLogBase#) | Just (a,b) <- naturalLiterals args@@ -1559,7 +1556,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = UniqMap.lookup tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(D# a) = wordToDouble i+ !(D# a) = castWord64ToDouble i !(# b, c #) = decodeDoubleInteger a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -1571,14 +1568,14 @@ , [i] <- integerLiterals' [iV] -> let !(I# k') = fromInteger j r = encodeDoubleInteger i k'- in reduce . Literal . DoubleLiteral . doubleToWord $ D# r+ in reduce . Literal . DoubleLiteral . castDoubleToWord64 $ D# r $(namePat 'GHC.Num.Integer.integerEncodeFloat#) | [iV, Lit (IntLiteral j)] <- args , [i] <- integerLiterals' [iV] -> let !(I# k') = fromInteger j r = integerEncodeFloat# i k'- in reduce . Literal . FloatLiteral . floatToWord $ F# r+ in reduce . Literal . FloatLiteral . castFloatToWord32 $ F# r $(namePat 'GHC.Num.Integer.integerQuotRem#) -- :: Integer -> Integer -> (#Integer, Integer#) | [i, j] <- integerLiterals' args@@ -1918,38 +1915,38 @@ -- ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real "GHC.Real.^_f" -- :: Integer -> Integer -> Integer | [i,j] <- integerLiterals' args- -> reduce (integerToIntegerLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntegerLiteral $ i ^ j)) "GHC.Real.$wf" -- :: Integer -> Int# -> Integer | [iV, Lit (IntLiteral j)] <- args , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntegerLiteral $ i ^ j)) "GHC.Real.$wf1" -- :: Int# -> Int# -> Int# | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Internal.Real.^_$s$spowImpl2" -- :: Int# -> Integer -> Integer | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Internal.Real.^_$s$spowImpl" -- :: Int -> Integer -> Integer | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Internal.Real.$w$spowImpl" -- :: Integer -> Int# -> Integer | [integerLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Internal.Real.$w$spowImpl1" -- :: Int# -> Int# -> Integer | [intLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Real.^_$s$spowImpl2" -- :: Int# -> Integer -> Integer | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Real.$w$spowImpl" -- :: Integer -> Int# -> Integer | [integerLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Real.$w$spowImpl1" -- :: Int# -> Int# -> Integer | [intLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) "GHC.Real.^_$sf2" -- :: Int# -> Integer -> Integer | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (integerToIntLiteral $ i ^ j)+ -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j)) -- Type level ^ -- XXX: Very fragile -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.@@ -2063,9 +2060,9 @@ -> case fromInteger matDigs of matDigs' | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d)))))+ -> reduce (Literal (FloatLiteral (castFloatToWord32 (fromRational (n :% d))))) | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d)))))+ -> reduce (Literal (DoubleLiteral (castDoubleToWord64 (fromRational (n :% d))))) _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double" "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile@@ -2077,9 +2074,9 @@ -> case fromInteger matDigs of matDigs' | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d)))))+ -> reduce (Literal (FloatLiteral (castFloatToWord32 (fromRational (n :% d))))) | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d)))))+ -> reduce (Literal (DoubleLiteral (castDoubleToWord64 (fromRational (n :% d))))) _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double" $(namePat 'GHC.Num.Integer.integerSignum#)@@ -2133,7 +2130,7 @@ | [ DC intDc [Left (Literal (IntLiteral i))] , DC _ [Left (Literal (IntLiteral j))] ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `quot` j))))+ -> reduce (catchDivByZero (App (Data intDc) (Literal (IntLiteral (i `quot` j))))) $(namePat 'Clash.Class.BitPack.Internal.packInt8#) -- :: Int8 -> BitVector 8 | [DC _ [Left arg]] <- args , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind@@ -2277,20 +2274,20 @@ | [ DC intDc [Left (Literal (IntLiteral i))] , DC _ [Left (Literal (IntLiteral j))] ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `rem` j))))+ -> reduce (catchDivByZero (App (Data intDc) (Literal (IntLiteral (i `rem` j))))) $(namePat 'GHC.Base.divInt) | [ DC intDc [Left (Literal (IntLiteral i))] , DC _ [Left (Literal (IntLiteral j))] ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `div` j))))+ -> reduce (catchDivByZero (App (Data intDc) (Literal (IntLiteral (i `div` j))))) $(namePat 'GHC.Base.modInt) | [ DC intDc [Left (Literal (IntLiteral i))] , DC _ [Left (Literal (IntLiteral j))] ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `mod` j))))+ -> reduce (catchDivByZero (App (Data intDc) (Literal (IntLiteral (i `mod` j))))) $(namePat 'Clash.Class.BitPack.Internal.packDouble#) -- :: Double -> BitVector 64 | [DC _ [Left arg]] <- args@@ -2923,28 +2920,28 @@ $(namePat 'Clash.Sized.Internal.BitVector.shiftL#) | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)+ in reduce (catchErrorCall (mkBitVectorLit ty nTy kn msk val)) where op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer) op u i _ = splitBV (BitVector.shiftL# u i) $(namePat 'Clash.Sized.Internal.BitVector.shiftR#) | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)+ in reduce (catchErrorCall (mkBitVectorLit ty nTy kn msk val)) where op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer) op u i _ = splitBV (BitVector.shiftR# u i) $(namePat 'Clash.Sized.Internal.BitVector.rotateL#) | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)+ in reduce (catchErrorCall (mkBitVectorLit ty nTy kn msk val)) where op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer) op u i _ = splitBV (BitVector.rotateL# u i) $(namePat 'Clash.Sized.Internal.BitVector.rotateR#) | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)+ in reduce (catchErrorCall (mkBitVectorLit ty nTy kn msk val)) where op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer) op u i _ = splitBV (BitVector.rotateR# u i)@@ -3235,28 +3232,28 @@ $(namePat 'Clash.Sized.Internal.Signed.shiftL#) | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkSignedLit ty nTy kn val)) where op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer op u i _ = toInteger (Signed.shiftL# u i) $(namePat 'Clash.Sized.Internal.Signed.shiftR#) | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkSignedLit ty nTy kn val)) where op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer op u i _ = toInteger (Signed.shiftR# u i) $(namePat 'Clash.Sized.Internal.Signed.rotateL#) | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkSignedLit ty nTy kn val)) where op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer op u i _ = toInteger (Signed.rotateL# u i) $(namePat 'Clash.Sized.Internal.Signed.rotateR#) | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkSignedLit ty nTy kn val)) where op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer op u i _ = toInteger (Signed.rotateR# u i)@@ -3437,28 +3434,28 @@ $(namePat 'Clash.Sized.Internal.Unsigned.shiftL#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkUnsignedLit ty nTy kn val)) where op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer op u i _ = toInteger (Unsigned.shiftL# u i) $(namePat 'Clash.Sized.Internal.Unsigned.shiftR#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkUnsignedLit ty nTy kn val)) where op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer op u i _ = toInteger (Unsigned.shiftR# u i) $(namePat 'Clash.Sized.Internal.Unsigned.rotateL#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkUnsignedLit ty nTy kn val)) where op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer op u i _ = toInteger (Unsigned.rotateL# u i) $(namePat 'Clash.Sized.Internal.Unsigned.rotateR#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)+ in reduce (catchErrorCall (mkUnsignedLit ty nTy kn val)) where op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer op u i _ = toInteger (Unsigned.rotateR# u i)@@ -3779,9 +3776,6 @@ , Left (Literal (NaturalLiteral (m-1)))]) ,Left v ]- -- Projection either the first or second field of the recursive- -- call to @splitAt@- splitAtSelR v = Case (splitAtRec v) m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy] nVecTy = mkTyConApp vecTcNm [nTy,aTy] -- Guaranteed no capture, so okay to use unsafe name generation@@ -3805,11 +3799,12 @@ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs)) -> case Either.lefts vArgs of (_ : x : xs : _) ->- reduce $+ let (mach1, recId) = newLetBinding tcm mach (splitAtRec xs)+ in reduceWith mach1 $ mkApps (Data tupDc) $ (map Right tyArgs) ++ [ Left (mkVecCons consCon aTy m' x- (splitAtSelR xs m1VecTy [lAlt]))- , Left (splitAtSelR xs nVecTy [rAlt])+ (Case (Var recId) m1VecTy [lAlt]))+ , Left (Case (Var recId) nVecTy [rAlt]) ] _ -> -- v actually reduces to Nil and not Cons, this only happens@@ -4195,13 +4190,19 @@ , Right n <- runExcept (tyNatSize tcm nTy) -> case n of 0 -> reduce (mkVecNil dc cTy)- n' -> reduce $ mkVecCons dc cTy n'- (mkApps (valToTerm f)+ -- We share the function 'f' and the second vector 'ys' via heap+ -- let-bindings instead of inlining 'valToTerm f' / 'valToTerm ys'+ -- twice. See #3308.+ n' ->+ let (mach1, fId) = newLetBinding tcm mach (valToTerm f)+ (mach2, ysId) = newLetBinding tcm mach1 (valToTerm ys)+ in reduceWith mach2 $ mkVecCons dc cTy n'+ (mkApps (Var fId) [Left (Either.lefts vArgs !! 1) ,Left (mkApps (vecHeadPrim vecTcNm) [Right (LitTy (NumTy (n'-1))) ,Right bTy- ,Left (valToTerm ys)+ ,Left (Var ysId) ]) ]) (mkApps (Prim pInfo)@@ -4209,12 +4210,12 @@ ,Right bTy ,Right cTy ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm f)+ ,Left (Var fId) ,Left (Either.lefts vArgs !! 2) ,Left (mkApps (vecTailPrim vecTcNm) [Right (LitTy (NumTy (n'-1))) ,Right bTy- ,Left (valToTerm ys)+ ,Left (Var ysId) ])]) -- Folding@@ -4647,10 +4648,10 @@ , (_, tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , Just tupTc <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (wordToDouble d)))+ -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (castWord64ToDouble d))) ret = mkApps (Data tupDc) (map Right tyArgs ++ [ Left (mkSignedLit sty nTy kn sn)- , Left (mkDoubleCLit tcm (doubleToWord d1) (last tyArgs))+ , Left (mkDoubleCLit tcm (castDoubleToWord64 d1) (last tyArgs)) ]) in reduce ret where@@ -4663,10 +4664,10 @@ , (_, tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty , Just tupTc <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc- -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (wordToDouble d)))+ -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (castWord64ToDouble d))) ret = mkApps (Data tupDc) (map Right tyArgs ++ [ Left (mkSignedLit sty nTy kn sn)- , Left (mkDoubleCLit tcm (doubleToWord d1) (last tyArgs))+ , Left (mkDoubleCLit tcm (castDoubleToWord64 d1) (last tyArgs)) ]) in reduce ret where@@ -4700,9 +4701,15 @@ f (map fromInteger natsAsInts) reduce :: Term -> Maybe Machine- reduce e = case isX e of+ reduce = reduceWith mach++ -- Like 'reduceWith, but reduces in (the heap of) an explicitly given machine+ -- rather than the captured 'mach'. Use this when the reduced term refers to+ -- bindings freshly allocated with 'newLetBinding'.+ reduceWith :: Machine -> Term -> Maybe Machine+ reduceWith mach0 e = case isX e of Left msg -> trace (unlines ["Warning: Not evaluating constant expression:", show (primName pInfo), "Because doing so generates an XException:", msg]) Nothing- Right e' -> Just (setTerm e' mach)+ Right e' -> Just (setTerm e' mach0) reduceWHNF e = let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind@@ -4711,7 +4718,7 @@ reduceWHNF' mach1 e = let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- mach2@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e mach1)+ mach2@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e $ stackClear mach1) in Just $ mach2 { mStack = mStack mach } makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term@@ -4729,6 +4736,8 @@ catchDivByZero = makeUndefinedIf (==DivideByZero) + catchErrorCall = makeUndefinedIf (const True :: ErrorCall -> Bool)+ -- Helper functions for literals pairOf :: (Value -> Maybe a) -> [Value] -> Maybe (a, a)@@ -5424,21 +5433,21 @@ _ -> Nothing runDDI :: (Double# -> Double# -> Int#) -> Word64 -> Word64 -> Term runDDI f i j- = let !(D# a) = wordToDouble i- !(D# b) = wordToDouble j+ = let !(D# a) = castWord64ToDouble i+ !(D# b) = castWord64ToDouble j r = f a b in Literal . IntLiteral . toInteger $ I# r runDDD :: (Double# -> Double# -> Double#) -> Word64 -> Word64 -> Term runDDD f i j- = let !(D# a) = wordToDouble i- !(D# b) = wordToDouble j+ = let !(D# a) = castWord64ToDouble i+ !(D# b) = castWord64ToDouble j r = f a b- in Literal . DoubleLiteral . doubleToWord $ D# r+ in Literal . DoubleLiteral . castDoubleToWord64 $ D# r runDD :: (Double# -> Double#) -> Word64 -> Term runDD f i- = let !(D# a) = wordToDouble i+ = let !(D# a) = castWord64ToDouble i r = f a- in Literal . DoubleLiteral . doubleToWord $ D# r+ in Literal . DoubleLiteral . castDoubleToWord64 $ D# r liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term liftFFI f args = case floatLiterals' args of@@ -5454,21 +5463,21 @@ _ -> Nothing runFFI :: (Float# -> Float# -> Int#) -> Word32 -> Word32 -> Term runFFI f i j- = let !(F# a) = wordToFloat i- !(F# b) = wordToFloat j+ = let !(F# a) = castWord32ToFloat i+ !(F# b) = castWord32ToFloat j r = f a b in Literal . IntLiteral . toInteger $ I# r runFFF :: (Float# -> Float# -> Float#) -> Word32 -> Word32 -> Term runFFF f i j- = let !(F# a) = wordToFloat i- !(F# b) = wordToFloat j+ = let !(F# a) = castWord32ToFloat i+ !(F# b) = castWord32ToFloat j r = f a b- in Literal . FloatLiteral . floatToWord $ F# r+ in Literal . FloatLiteral . castFloatToWord32 $ F# r runFF :: (Float# -> Float#) -> Word32 -> Term runFF f i- = let !(F# a) = wordToFloat i+ = let !(F# a) = castWord32ToFloat i r = f a- in Literal . FloatLiteral . floatToWord $ F# r+ in Literal . FloatLiteral . castFloatToWord32 $ F# r liftI8 :: (Int8# -> Int8# -> Int8#) -> [Value] -> Maybe Term liftI8 f args = case int8Literals' args of
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -41,7 +41,7 @@ import Control.Monad.RWS.Strict (RWS) import qualified Control.Monad.RWS.Strict as RWS import Data.Bifunctor (second)-import Data.Binary.IEEE754 (doubleToWord, floatToWord)+import GHC.Float (castDoubleToWord64, castFloatToWord32) import qualified Data.ByteString.Char8 as Char8 import Data.Char (isDigit) import Data.Hashable (Hashable (..))@@ -606,8 +606,8 @@ LitNumWord8 -> C.Word8Literal i LitNumWord16 -> C.Word16Literal i LitNumWord32 -> C.Word32Literal i- LitFloat r -> C.FloatLiteral . floatToWord $ fromRational r- LitDouble r -> C.DoubleLiteral . doubleToWord $ fromRational r+ LitFloat r -> C.FloatLiteral . castFloatToWord32 $ fromRational r+ LitDouble r -> C.DoubleLiteral . castDoubleToWord64 $ fromRational r LitNullAddr -> C.StringLiteral [] #if MIN_VERSION_ghc(9,12,0) LitLabel fs _ -> C.StringLiteral (unpackFS fs)
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -6,6 +6,7 @@ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -16,9 +17,9 @@ where import Control.Arrow ((***))-import Control.DeepSeq (deepseq)-import Control.Lens ((%~),(&),(.~))-import Control.Monad (unless)+import Control.DeepSeq (NFData, deepseq)+import Control.Lens ((%~),(&),(.~),(^.))+import Control.Monad (forM, unless) import qualified Control.Monad.State as State import qualified Control.Monad.RWS.Strict as RWS import Data.Coerce (coerce)@@ -26,10 +27,15 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IMS import qualified Data.HashMap.Strict as HashMap+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif import Data.List (isPrefixOf)+import Data.List.Split (chunksOf) import Data.Maybe (listToMaybe) import qualified Data.Text as Text import qualified Data.Time.Clock as Clock+import GHC.Conc (numCapabilities, par, pseq) import qualified GHC as GHC (Ghc) import qualified GHC.Types.SourceText as GHC@@ -206,45 +212,105 @@ , VarEnv (Id,Int) ) mkBindings primMap bindings clsOps unlocatable = do- bindingsList <- mapM (\case- GHC.NonRec v e -> do- let sp = GHC.getSrcSpan v+ -- Converting each binder is independent: 'GHC2CoreState' only accumulates a+ -- 'TyCon' map and a name cache, both of which are pure (deterministic per+ -- key) memo tables. We therefore convert every binder from a fresh state in+ -- parallel and merge the resulting 'TyCon' maps afterwards. See 'parRunC2C'.+ env <- RWS.ask+ let+ bindingsList = parRunC2C env (map (processBind primMap unlocatable) bindings)+ clsOpList = parRunC2C env (map processClsOp clsOps)+ -- Merge the 'TyCon' maps discovered while converting; the name caches are+ -- not used after this point, so they are dropped. 'makeAllTyCons' later+ -- recomputes over the merged map, so a plain union suffices.+ RWS.modify (tyConMap %~ \tcm0 ->+ foldl' (\acc st -> acc <> (st ^. tyConMap)) tcm0+ (map snd bindingsList ++ map snd clsOpList))++ return ( mkVarEnv (concatMap fst bindingsList)+ , mkVarEnv (map fst clsOpList) )++-- | Convert a single (possibly recursive) binder group to Clash Core bindings.+-- See 'mkBindings' for how these conversions are run in parallel.+processBind+ :: CompiledPrimMap+ -> [GHC.CoreBndr]+ -> GHC.CoreBind+ -> C2C [(Id, Binding Term)]+processBind primMap unlocatable = \case+ GHC.NonRec v e -> do+ let sp = GHC.getSrcSpan v+ inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v+ tm <- RWS.local (srcSpan .~ sp) (coreToTerm primMap unlocatable e)+ v' <- coreToId v+ nm <- qualifiedNameString (GHC.varName v)+ let pr = if HashMap.member nm primMap then IsPrim else IsFun+ checkPrimitive primMap v+ return [(v', (Binding v' sp inl pr tm False))]+ GHC.Rec bs -> do+ tms <- forM bs $ \(v,e) -> do+ let sp = GHC.getSrcSpan v inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v tm <- RWS.local (srcSpan .~ sp) (coreToTerm primMap unlocatable e) v' <- coreToId v nm <- qualifiedNameString (GHC.varName v) let pr = if HashMap.member nm primMap then IsPrim else IsFun checkPrimitive primMap v- return [(v', (Binding v' sp inl pr tm False))]- GHC.Rec bs -> do- tms <- mapM (\(v,e) -> do- let sp = GHC.getSrcSpan v- inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v- tm <- RWS.local (srcSpan .~ sp) (coreToTerm primMap unlocatable e)- v' <- coreToId v- nm <- qualifiedNameString (GHC.varName v)- let pr = if HashMap.member nm primMap then IsPrim else IsFun- checkPrimitive primMap v- return (Binding v' sp inl pr tm True)- ) bs- case tms of- [Binding v sp inl pr tm r] -> return [(v, Binding v sp inl pr tm r)]+ return (Binding v' sp inl pr tm True)+ case tms of+ [Binding v sp inl pr tm r] -> return [(v, Binding v sp inl pr tm r)] - -- Rewrite the bindings to avoid triggering the recursion check.- -- See NOTE [bindings in recursive groups]- _ -> let vsL = map (setIdScope LocalId . bindingId) tms- vsV = map Var vsL- subst = extendGblSubstList (mkSubst emptyInScopeSet) (zip vsL vsV)- lbs = zipWith (\b vL -> (vL,substTm "mkBindings" subst (bindingTerm b))) tms vsL- tms1 = zipWith (\b (i, _) -> (bindingId b, b { bindingTerm = Letrec lbs (Var i), bindingRecursive = False })) tms lbs- in return tms1- ) bindings- clsOpList <- mapM (\(v,i) -> do- v' <- coreToId v- return (v', (v',i))- ) clsOps+ -- Rewrite the bindings to avoid triggering the recursion check.+ -- See NOTE [bindings in recursive groups]+ _ -> let vsL = map (setIdScope LocalId . bindingId) tms+ vsV = map Var vsL+ subst = extendGblSubstList (mkSubst emptyInScopeSet) (zip vsL vsV)+ lbs = zipWith (\b vL -> (vL,substTm "mkBindings" subst (bindingTerm b))) tms vsL+ tms1 = zipWith (\b (i, _) -> (bindingId b, b { bindingTerm = Letrec lbs (Var i), bindingRecursive = False })) tms lbs+ in return tms1 - return (mkVarEnv (concat bindingsList), mkVarEnv clsOpList)+-- | Convert a single class operation. See 'processBind'.+processClsOp :: (GHC.CoreBndr, Int) -> C2C (Id, (Id, Int))+processClsOp (v,i) = do+ v' <- coreToId v+ return (v', (v',i))++-- | Run a list of independent 'C2C' computations, each starting from an empty+-- 'GHC2CoreState', forcing their results to normal form in parallel across the+-- available capabilities. Returns each computation's result paired with the+-- state it produced (so the caller can merge the accumulated 'TyCon' maps).+--+-- This only runs in parallel when the RTS has more than one capability, i.e.,+-- when the executable is run with @+RTS -N@ or built with @-with-rtsopts=-N@.+-- With a single capability it degrades to sequential evaluation.+parRunC2C :: NFData a => GHC2CoreEnv -> [C2C a] -> [(a, GHC2CoreState)]+parRunC2C env ms = parListChunk chunkSize forceResult (map runC2C ms)+ where+ runC2C m = case RWS.runRWS m env emptyGHC2CoreState of+ (a, s, _w) -> (a, s)+ -- Force the converted result to normal form (this is the expensive+ -- 'coreToTerm' work we want to parallelize). The state is left to be forced+ -- lazily when its 'TyCon' map is merged; its entries are cheap GHC 'TyCon'+ -- references (the heavy 'makeAllTyCons' conversion happens later).+ forceResult p@(a, _s) = a `deepseq` p+ -- Keep chunks small so the work stays balanced even when a few binders are+ -- far larger than the rest; ~16 measured as a good size on large downstream+ -- designs. For small designs we make chunks finer still, scaling with the+ -- number of capabilities, but never below 1.+ chunkSize = min 16 (max 1 (length ms `div` (numCapabilities * 4)))++-- | Evaluate a list in parallel, in chunks, using only @base@ (@par@/@pseq@).+-- Equivalent in spirit to @Control.Parallel.Strategies@' @parListChunk n@ with+-- a caller-supplied forcing function, but avoids adding a dependency.+parListChunk :: Int -> (a -> a) -> [a] -> [a]+parListChunk n forceElem = concat . go . chunksOf n+ where+ forceChunk c = foldr (\x xs -> forceElem x `pseq` xs) () c `pseq` c+ go [] = []+ go (c:cs) =+ let c' = forceChunk c+ cs' = go cs+ in c' `par` (cs' `pseq` (c' : cs')) {- NOTE [bindings in recursive groups]
src-ghc/Clash/GHC/LoadModules.hs view
@@ -184,6 +184,10 @@ -> String -- ^ Module name. Can either be a filepath pointing to a .hs file, or a -- qualified module name (example: "Data.List").+ -> Maybe String+ -- ^ Name passed with @-main-is@, if any. When set, only the transitive+ -- closure of this binder is loaded (instead of the closure of all exports of+ -- the module). See 'loadSeed'. -> m (Either SomeException ( [CoreSyn.CoreBndr] -- Root binders@@ -192,17 +196,68 @@ , LoadedBinders , [CoreSyn.CoreBind] -- All bindings ) )-loadExternalModule hdl modName0 = MC.try $ do+loadExternalModule hdl modName0 mainIsM = MC.try $ do let modName1 = GHC.mkModuleName modName0 foundMod <- GHC.findModule modName1 Nothing let errMsg = "Internal error: found module, but could not load it" modInfo <- fromMaybe (error errMsg) <$> (GHC.getModuleInfo foundMod) tyThings <- catMaybes <$> mapM GHC.lookupGlobalName (GHC.modInfoExports modInfo) let rootIds = [id_ | GHC.AnId id_ <- tyThings]- loaded <- loadExternalBinders hdl rootIds+ -- Only load (the transitive closure of) the binders we will actually compile.+ -- With @-main-is@ that is the requested binder plus any other binder that+ -- 'loadModules' can still select as a top entity (see 'loadSeed'); without it,+ -- all exports.+ seed <- loadSeed mainIsM rootIds+ loaded <- loadExternalBinders hdl seed let allBinders = makeRecursiveGroups (Map.assocs (lbBinders loaded))+ -- NB: we return the /full/ export list as the root binders, so resolution of+ -- the @-main-is@ name and of (testbench/synthesize) annotations in+ -- 'loadModules' is unaffected by the pruning above. return (rootIds, FamInstEnv.emptyFamInstEnv, modName1, loaded, allBinders) +-- | Restrict the set of binders we load the transitive closure of. When a+-- @-main-is@ name is given we do not need every export: any binder (and its+-- closure) that is not selected as a top entity would be loaded, converted to+-- Clash Core, and then discarded by 'Clash.GHCi.Common.getMainTopEntity'. When+-- no name is given we keep all exports.+--+-- The seed must cover /every/ binder that 'loadModules' can select as a top+-- entity, otherwise that binder is chosen but its binding is never loaded,+-- leading to a spurious \"No top entity called ...\" error (see #3297). Besides+-- the @-main-is@ binder itself, this is:+--+-- * magically named exports @topEntity@ and @testBench@;+-- * @Synthesize@- and @TestBench@-annotated exports, and the designs under+-- test the latter point at.+--+-- These match the implicit top entities computed in 'loadModules'. We do not+-- prune them further based on @-main-is@ here, as 'getMainTopEntity' does that+-- downstream; loading their (small) closures is cheap and keeps this in step+-- with the selection logic.+--+-- If the @-main-is@ name cannot be found among the exports we fall back to all+-- exports and let 'loadModules' produce the usual \"no top-level function+-- called ...\" error.+loadSeed+ :: GHC.GhcMonad m+ => Maybe String+ -> [CoreSyn.CoreBndr]+ -> m [CoreSyn.CoreBndr]+loadSeed Nothing rootIds = pure rootIds+loadSeed (Just nm) rootIds =+ case filter ((== nm) . varNameString) rootIds of+ [] -> pure rootIds+ mainIs -> do+ synAnns <- findSynthesizeAnnotations rootIds+ benchAnns <- findTestBenches rootIds+ let+ implicit =+ map fst synAnns+ <> Map.keys benchAnns+ <> concat (Map.elems benchAnns)+ <> filter isMagicName rootIds+ pure (nubSort (mainIs <> implicit))+ setupGhc :: GHC.GhcMonad m => OverridingBool@@ -398,6 +453,22 @@ varNameString :: Var.Var -> String varNameString = nameString . Var.varName +-- | Is the binder magically named @topEntity@? Such binders are implicitly+-- treated as top entities (see 'isMagicName').+isTopEntityName :: Var.Var -> Bool+isTopEntityName = (== "topEntity") . varNameString++-- | Is the binder magically named @testBench@? Such binders are implicitly+-- treated as top entities (see 'isMagicName').+isTestBenchName :: Var.Var -> Bool+isTestBenchName = (== "testBench") . varNameString++-- | Is the binder magically named, i.e. called @topEntity@ or @testBench@?+-- These are picked up as top entities even without a @Synthesize@/@TestBench@+-- annotation.+isMagicName :: Var.Var -> Bool+isMagicName v = isTopEntityName v || isTestBenchName v+ data LoadModulesException = LoadModulesException { moduleName :: String , externalError :: String@@ -455,15 +526,11 @@ let setupStartDiff = reportTimeDiff setupTime startTime MonadUtils.liftIO $ putStrLn $ "GHC: Setting up GHC took: " ++ setupStartDiff - -- TODO: We currently load the transitive closure of _all_ bindings found- -- TODO: in the top module. This is wasteful if one or more binders don't- -- TODO: contribute to any top entities. This effect is worsened when using- -- TODO: -main-is, which only synthesizes a single top entity (and all its- -- TODO: dependencies).+ let mainIsM = GHC.mainFunIs =<< dflagsM (rootIds, modFamInstEnvs, _rootModule, LoadedBinders{..}, allBinders) <- -- We need to try and load external modules first, because we can't -- recover from errors in 'loadLocalModule'.- loadExternalModule hdl modName >>= \case+ loadExternalModule hdl modName mainIsM >>= \case Left loadExternalErr -> do catch @_ @SomeException (loadLocalModule hdl modName)@@ -503,12 +570,11 @@ -- TestBench and the binders they're pointing to, plus magically named -- functions called "topEntity" or "testBench". Synthesized in case user -- didn't specify a particular target.- isMagicName = (`elem` ["topEntity", "testBench"]) allImplicit = nubSort $ Map.keys benchAnn <> Map.keys allSyn <> concat (Map.elems benchAnn)- <> filter (isMagicName . varNameString) rootIds+ <> filter isMagicName rootIds <> topSyn -- Top entities we wish to synthesize. Users can filter these with -main-is.@@ -797,8 +863,8 @@ -- Special case magic name 'testBench'. See function documentation. specialCaseMagicName m = let- topEntM = find ((=="topEntity") . varNameString) bndrs0- tbM = find ((=="testBench") . varNameString) bndrs0+ topEntM = find isTopEntityName bndrs0+ tbM = find isTestBenchName bndrs0 in case (topEntM, tbM) of (Just dut, Just tb) -> insertTb m (dut, tb)