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/cbits/PosixSource.h b/cbits/PosixSource.h deleted file mode 100644 --- a/cbits/PosixSource.h +++ /dev/null @@ -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 - -/* 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 */ diff --git a/cbits/hschooks.c b/cbits/hschooks.c deleted file mode 100644 --- a/cbits/hschooks.c +++ /dev/null @@ -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 -#include - -#ifdef HAVE_UNISTD_H -#include -#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' option to increase it.\n", - (size_t) stack_size); -} diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -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. 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 diff --git a/src-ghc/Clash/GHC/ClashFlags.hs b/src-ghc/Clash/GHC/ClashFlags.hs --- a/src-ghc/Clash/GHC/ClashFlags.hs +++ b/src-ghc/Clash/GHC/ClashFlags.hs @@ -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 }) diff --git a/src-ghc/Clash/GHC/Evaluator/Primitive.hs b/src-ghc/Clash/GHC/Evaluator/Primitive.hs --- a/src-ghc/Clash/GHC/Evaluator/Primitive.hs +++ b/src-ghc/Clash/GHC/Evaluator/Primitive.hs @@ -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 diff --git a/src-ghc/Clash/GHC/GHC2Core.hs b/src-ghc/Clash/GHC/GHC2Core.hs --- a/src-ghc/Clash/GHC/GHC2Core.hs +++ b/src-ghc/Clash/GHC/GHC2Core.hs @@ -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) diff --git a/src-ghc/Clash/GHC/GenerateBindings.hs b/src-ghc/Clash/GHC/GenerateBindings.hs --- a/src-ghc/Clash/GHC/GenerateBindings.hs +++ b/src-ghc/Clash/GHC/GenerateBindings.hs @@ -6,6 +6,7 @@ Maintainer : QBayLogic B.V. -} +{-# 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] diff --git a/src-ghc/Clash/GHC/LoadModules.hs b/src-ghc/Clash/GHC/LoadModules.hs --- a/src-ghc/Clash/GHC/LoadModules.hs +++ b/src-ghc/Clash/GHC/LoadModules.hs @@ -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)