clash-ghc 1.2.5 → 1.4.0
raw patch · 32 files changed
+13973/−4736 lines, 32 filesdep +extradep +ghc-bignumdep ~Win32dep ~clash-libdep ~clash-preludePVP ok
version bump matches the API change (PVP)
Dependencies added: extra, ghc-bignum
Dependency ranges changed: Win32, clash-lib, clash-prelude, ghc, ghc-boot, ghc-prim, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, ghci, lens, template-haskell
API changes (from Hackage documentation)
- Clash.GHC.Evaluator: instance Clash.Util.MonadUnique Clash.GHC.Evaluator.PrimEvalMonad
- Clash.GHC.Evaluator: instance Control.Monad.State.Class.MonadState Control.Concurrent.Supply.Supply Clash.GHC.Evaluator.PrimEvalMonad
- Clash.GHC.Evaluator: instance GHC.Base.Applicative Clash.GHC.Evaluator.PrimEvalMonad
- Clash.GHC.Evaluator: instance GHC.Base.Functor Clash.GHC.Evaluator.PrimEvalMonad
- Clash.GHC.Evaluator: instance GHC.Base.Monad Clash.GHC.Evaluator.PrimEvalMonad
- Clash.GHC.Evaluator: isUndefinedPrimVal :: Value -> Bool
- Clash.GHC.Evaluator: primEvaluator :: PrimEvaluator
- Clash.GHCi.Common: checkClashDynamic :: DynFlags -> IO ()
+ Clash.GHC.Evaluator: allocate :: [LetBinding] -> Term -> Machine -> Machine
+ Clash.GHC.Evaluator: apply :: TyConMap -> Value -> Id -> Machine -> Machine
+ Clash.GHC.Evaluator: evaluator :: Evaluator
+ Clash.GHC.Evaluator: ghcStep :: Step
+ Clash.GHC.Evaluator: ghcUnwind :: Unwind
+ Clash.GHC.Evaluator: instantiate :: TyConMap -> Value -> Type -> Machine -> Machine
+ Clash.GHC.Evaluator: letSubst :: PureHeap -> Supply -> Id -> (Supply, (Id, (Id, Term)))
+ Clash.GHC.Evaluator: newBinder :: [Either TyVar Type] -> Term -> Step
+ Clash.GHC.Evaluator: newLetBinding :: TyConMap -> Machine -> Term -> (Machine, Id)
+ Clash.GHC.Evaluator: scrutinise :: Value -> Type -> [Alt] -> Machine -> Machine
+ Clash.GHC.Evaluator: stepApp :: Term -> Term -> Step
+ Clash.GHC.Evaluator: stepCase :: Term -> Type -> [Alt] -> Step
+ Clash.GHC.Evaluator: stepCast :: Term -> Type -> Type -> Step
+ Clash.GHC.Evaluator: stepData :: DataCon -> Step
+ Clash.GHC.Evaluator: stepLam :: Id -> Term -> Step
+ Clash.GHC.Evaluator: stepLetRec :: [LetBinding] -> Term -> Step
+ Clash.GHC.Evaluator: stepLiteral :: Literal -> Step
+ Clash.GHC.Evaluator: stepPrim :: PrimInfo -> Step
+ Clash.GHC.Evaluator: stepTick :: TickInfo -> Term -> Step
+ Clash.GHC.Evaluator: stepTyApp :: Term -> Type -> Step
+ Clash.GHC.Evaluator: stepTyLam :: TyVar -> Term -> Step
+ Clash.GHC.Evaluator: stepVar :: Id -> Step
+ Clash.GHC.Evaluator: substInAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term
+ Clash.GHC.Evaluator: update :: IdScope -> Id -> Value -> Machine -> Machine
+ Clash.GHC.Evaluator.Primitive: ghcPrimStep :: PrimStep
+ Clash.GHC.Evaluator.Primitive: ghcPrimUnwind :: PrimUnwind
+ Clash.GHC.Evaluator.Primitive: instance Clash.Util.MonadUnique Clash.GHC.Evaluator.Primitive.PrimEvalMonad
+ Clash.GHC.Evaluator.Primitive: instance Control.Monad.State.Class.MonadState Control.Concurrent.Supply.Supply Clash.GHC.Evaluator.Primitive.PrimEvalMonad
+ Clash.GHC.Evaluator.Primitive: instance GHC.Base.Applicative Clash.GHC.Evaluator.Primitive.PrimEvalMonad
+ Clash.GHC.Evaluator.Primitive: instance GHC.Base.Functor Clash.GHC.Evaluator.Primitive.PrimEvalMonad
+ Clash.GHC.Evaluator.Primitive: instance GHC.Base.Monad Clash.GHC.Evaluator.Primitive.PrimEvalMonad
+ Clash.GHC.Evaluator.Primitive: isUndefinedPrimVal :: Value -> Bool
+ Clash.GHC.PartialEval: ghcEvaluator :: Evaluator
+ Clash.GHC.PartialEval.Eval: apply :: Value -> Value -> Eval Value
+ Clash.GHC.PartialEval.Eval: applyTy :: Value -> Type -> Eval Value
+ Clash.GHC.PartialEval.Eval: eval :: Term -> Eval Value
+ Clash.GHC.PartialEval.Primitive: evalPrimitive :: (Term -> Eval Value) -> PrimInfo -> Args Value -> Eval Value
+ Clash.GHC.PartialEval.Quote: quote :: Value -> Eval Normal
+ Clash.Main: defaultMainWithAction :: Ghc () -> [String] -> IO ()
- Clash.GHC.GenerateBindings: generateBindings :: OverridingBool -> [FilePath] -> [FilePath] -> [FilePath] -> HDL -> String -> Maybe DynFlags -> IO (BindingMap, TyConMap, IntMap TyConName, [TopEntityT], CompiledPrimMap, [DataRepr'])
+ Clash.GHC.GenerateBindings: generateBindings :: Ghc () -> OverridingBool -> [FilePath] -> [FilePath] -> [FilePath] -> HDL -> String -> Maybe DynFlags -> IO (BindingMap, TyConMap, IntMap TyConName, [TopEntityT], CompiledPrimMap, [DataRepr'], HashMap Text VDomainConfiguration)
- Clash.GHC.LoadModules: loadModules :: OverridingBool -> HDL -> String -> Maybe DynFlags -> [FilePath] -> IO ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs, [(CoreBndr, Maybe TopEntity, Maybe CoreBndr)], [Either UnresolvedPrimitive FilePath], [DataRepr'], [(Text, PrimitiveGuard ())])
+ Clash.GHC.LoadModules: loadModules :: Ghc () -> OverridingBool -> HDL -> String -> Maybe DynFlags -> [FilePath] -> IO ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs, [(CoreBndr, Maybe TopEntity, Bool)], [Either UnresolvedPrimitive FilePath], [DataRepr'], [(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
Files
- CHANGELOG.md +88/−0
- clash-ghc.cabal +38/−16
- src-bin-8.10/Clash/GHCi/UI.hs +26/−8
- src-bin-8.10/Clash/Main.hs +20/−14
- src-bin-841/Clash/GHCi/UI.hs +28/−11
- src-bin-841/Clash/Main.hs +25/−18
- src-bin-861/Clash/GHCi/UI.hs +28/−11
- src-bin-861/Clash/Main.hs +21/−18
- src-bin-881/Clash/GHCi/UI.hs +25/−8
- src-bin-881/Clash/Main.hs +20/−15
- src-bin-9.0/Clash/GHCi/Leak.hs +74/−0
- src-bin-9.0/Clash/GHCi/UI.hs +4579/−0
- src-bin-9.0/Clash/GHCi/UI/Info.hs +384/−0
- src-bin-9.0/Clash/GHCi/UI/Monad.hs +532/−0
- src-bin-9.0/Clash/GHCi/UI/Tags.hs +217/−0
- src-bin-9.0/Clash/GHCi/Util.hs +16/−0
- src-bin-9.0/Clash/Main.hs +1077/−0
- src-bin-common/Clash/GHCi/Common.hs +36/−29
- src-ghc/Clash/GHC/ClashFlags.hs +47/−6
- src-ghc/Clash/GHC/Evaluator.hs +476/−4437
- src-ghc/Clash/GHC/Evaluator.hs-boot +12/−0
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +4778/−0
- src-ghc/Clash/GHC/GHC2Core.hs +110/−14
- src-ghc/Clash/GHC/GenerateBindings.hs +82/−23
- src-ghc/Clash/GHC/LoadInterfaceFiles.hs +89/−22
- src-ghc/Clash/GHC/LoadModules.hs +323/−85
- src-ghc/Clash/GHC/NetlistTypes.hs +12/−0
- src-ghc/Clash/GHC/PartialEval.hs +24/−0
- src-ghc/Clash/GHC/PartialEval/Eval.hs +620/−0
- src-ghc/Clash/GHC/PartialEval/Primitive.hs +57/−0
- src-ghc/Clash/GHC/PartialEval/Quote.hs +99/−0
- src-ghc/Clash/GHC/Util.hs +10/−1
CHANGELOG.md view
@@ -1,5 +1,90 @@ # Changelog for the Clash project+## 1.4.0 *March 12th 2020*+Highlighted changes (repeated in other categories): + * Clash no longer disables the monomorphism restriction. See [#1270](https://github.com/clash-lang/clash-compiler/issues/1270), and mentioned issues, as to why. This can cause, among other things, certain eta-reduced descriptions of sequential circuits to no longer type-check. See [#1349](https://github.com/clash-lang/clash-compiler/pull/1349) for code hints on what kind of changes to make to your own code in case it no longer type-checks due to this change.+ * Type arguments of `Clash.Sized.Vector.fold` swapped: before `forall a n . (a -> a -> a) -> Vec (n+1) a -> a`, after `forall n a . (a -> a -> a) -> Vec (n+1) a`. This makes it easier to use `fold` in a `1 <= n` context so you can "simply" do `fold @(n-1)`+ * `Fixed` now obeys the laws for `Enum` as set out in the Haskell Report, and it is now consistent with the documentation for the `Enum` class on Hackage. As `Fixed` is also `Bounded`, the rule in the Report that `succ maxBound` and `pred minBound` should result in a runtime error is interpreted as meaning that `succ` and `pred` result in a runtime error whenever the result cannot be represented, not merely for `minBound` and `maxBound` alone.+ * Primitives should now be stored in `*.primitives` files instead of `*.json`. While primitive files very much look like JSON files, they're not actually spec complaint as they use newlines in strings. This has recently been brought to our attention by Aeson fixing an oversight in their parser implementation. We've therefore decided to rename the extension to prevent confusion.++Fixed:+ * Result of `Clash.Class.Exp.(^)` has enough bits in order to deal with `x^0`.+ * Resizes to `Signed 0` (e.g., `resize @(Signed n) @(Signed 0)`) don't throw an error anymore+ * `satMul` now correctly handles arguments of type `Index 2`+ * `Clash.Explicit.Reset.resetSynchronizer` now synchronizes on synchronous domains too [#1567](https://github.com/clash-lang/clash-compiler/pull/1567).+ * `Clash.Explicit.Reset.convertReset`: now converts synchronous domains too, if necessary [#1567](https://github.com/clash-lang/clash-compiler/pull/1567).+ * `inlineWorkFree` now never inlines a topentity. It previously only respected this invariant in one of the two cases [#1587](https://github.com/clash-lang/clash-compiler/pull/1587).+ * Clash now reduces recursive type families [#1591](https://github.com/clash-lang/clash-compiler/issues/1591)+ * Primitive template warning is now retained when a `PrimitiveGuard` annotation is present [#1625](https://github.com/clash-lang/clash-compiler/issues/1625)+ * `signum` and `RealFrac` for `Fixed` now give the correct results.+ * Fixed a memory leak in register when used on asynchronous domains. Although the memory leak has always been there, it was only triggered on asserted resets. These periods are typically short, hence typically unnoticable.+ * `createDomain` will not override user definitions of types, helping users who strive for complete documentation coverage [#1674] https://github.com/clash-lang/clash-compiler/issues/1674+ * `fromSNat` is now properly constrained [#1692](https://github.com/clash-lang/clash-compiler/issues/1692)+ * As part of an internal overhaul on netlist identifier generation [#1265](https://github.com/clash-lang/clash-compiler/pull/1265):+ * Clash no longer produces "name conflicts" between basic and extended identifiers. I.e., `\x\` and `x` are now considered the same variable in VHDL (likewise for other HDLs). Although the VHDL spec considers them distinct variables, some HDL tools - like Quartus - don't.+ * Capitalization of Haskell names are now preserved in VHDL. Note that VHDL is a case insensitive languages, so there are measures in place to prevent Clash from generating both `Foo` and `fOO`. This used to be handled by promoting every capitalized identifier to an extended one and wasn't handled for basic ones.+ * Names generated for testbenches can no longer cause collisions with previously generated entities.+ * Names generated for components can no longer cause collisions with user specified top entity names.+ * For (System)Verilog, variables can no longer cause collisions with (to be) generated entity names.+ * HO blackboxes can no longer cause collisions with identifiers declared in their surrounding architecture block.+++Changed:+ * Treat enable lines specially in generated HDL [#1171](https://github.com/clash-lang/clash-compiler/issues/1171)+ * `Signed`, `Unsigned`, `SFixed`, and `UFixed` now correctly implement the `Enum` law specifying that the predecessor of `minBound` and the successor of `maxBound` should result in an error [#1495](https://github.com/clash-lang/clash-compiler/pull/1495).+ * `Fixed` now obeys the laws for `Enum` as set out in the Haskell Report, and it is now consistent with the documentation for the `Enum` class on Hackage. As `Fixed` is also `Bounded`, the rule in the Report that `succ maxBound` and `pred minBound` should result in a runtime error is interpreted as meaning that `succ` and `pred` result in a runtime error whenever the result cannot be represented, not merely for `minBound` and `maxBound` alone.+ * Type arguments of `Clash.Sized.Vector.fold` swapped: before `forall a n . (a -> a -> a) -> Vec (n+1) a -> a`, after `forall n a . (a -> a -> a) -> Vec (n+1) a`. This makes it easier to use `fold` in a `1 <= n` context so you can "simply" do `fold @(n-1)`+ * Moved `Clash.Core.Evaluator` into `Clash.GHC` and provided generic interface in `Clash.Core.Evalautor.Types`. This removes all GHC specific code from the evaluator in clash-lib.+ * Clash no longer disables the monomorphism restriction. See [#1270](https://github.com/clash-lang/clash-compiler/issues/1270), and mentioned issues, as to why. This can cause, among other things, certain eta-reduced descriptions of sequential circuits to no longer type-check. See [#1349](https://github.com/clash-lang/clash-compiler/pull/1349) for code hints on what kind of changes to make to your own code in case it no longer type-checks due to this change.+ * Clash now generates SDC files for each topentity with clock inputs+ * `deepErrorX` is now equal to `undefined#`, which means that instead of the whole BitVector being undefined, its individual bits are. This makes sure bit operations are possible on it. [#1532](https://github.com/clash-lang/clash-compiler/pull/1532)+ * From GHC 9.0.1 onwards the following types: `BiSignalOut`, `Index`, `Signed`, `Unsigned`, `File`, `Ref`, and `SimIO` are all encoded as `data` instead of `newtype` to work around an [issue](https://github.com/clash-lang/clash-compiler/pull/1624#discussion_r558333461) where the Clash compiler can no longer recognize primitives over these types. This means you can no longer use `Data.Coerce.coerce` to coerce between these types and their underlying representation.+ * Signals on different domains used to be coercable because the domain had a type role "phantom". This has been changed to "nominal" to prevent accidental, unsafe coercions. [#1640](https://github.com/clash-lang/clash-compiler/pull/1640)+ * Size parameters on types in Clash.Sized.Internal.* are now nominal to prevent unsafe coercions. [#1640](https://github.com/clash-lang/clash-compiler/pull/1640)+ * `hzToPeriod` now takes a `Ratio Natural` rather than a `Double`. It rounds slightly differently, leading to more intuitive results and satisfying the requested change in [#1253](https://github.com/clash-lang/clash-compiler/issues/1253). Clash expresses clock rate as the clock period in picoseconds. If picosecond precision is required for your design, please use the exact method of specifying a clock period rather than a clock frequency.+ * `periodToHz` now results in a `Ratio Natural`+ * `createDomain` doesn't override existing definitions anymore, fixing [#1674](https://github.com/clash-lang/clash-compiler/issues/1674)+ * Manifest files are now stored as `clash-manifest.json`+ * Manifest files now store hashes of the files Clash generated. This allows Clash to detect user changes on a next run, preventing accidental data loss.+ * Primitives should now be stored in `*.primitives` files. While primitive files very much look like JSON files, they're not actually spec complaint as they use newlines in strings. This has recently been brought to our attention by Aeson fixing an oversight in their parser implementation. We've therefore decided to rename the extension to prevent confusion.+ * Each binder marked with a `Synthesize` or `TestBench` pragma will be put in its own directory under their fully qualified Haskell name. For example, two binders `foo` and `bar` in module `A` will be synthesized in `A.foo` and `A.bar`.+ * Clash will no longer generate vhdl, verilog, or systemverilog subdirectories when using `-fclash-hdldir`.+ * `Data.Kind.Type` is now exported from `Clash.Prelude` [#1700](https://github.com/clash-lang/clash-compiler/issues/1700)+++Added:+ * Support for GHC 9.0.1+ * `Clash.Signal.sameDomain`: Allows user obtain evidence whether two domains are equal.+ * `xToErrorCtx`: makes it easier to track the origin of `XException` where `pack` would hide them [#1461](https://github.com/clash-lang/clash-compiler/pull/1461)+ * Additional field with synthesis attributes added to `InstDecl` in `Clash.Netlist.Types` [#1482](https://github.com/clash-lang/clash-compiler/pull/1482)+ * `Data.Ix.Ix` instances for `Signed`, `Unsigned`, and `Index` [#1481](https://github.com/clash-lang/clash-compiler/pull/1481) [#1631](https://github.com/clash-lang/clash-compiler/pull/1631)+ * Added `nameHint` to allow explicitly naming terms, e.g. `Signal`s.+ * Checked versions of `resize`, `truncateB`, and `fromIntegral`. Depending on the type `resize`, `truncateB`, and `fromIntegral` either yield an `XException` or silently perform wrap-around if its argument does not fit in the resulting type's bounds. The added functions check the bound condition and fail with an error call if the condition is violated. They do not affect HDL generation. [#1491](https://github.com/clash-lang/clash-compiler/pull/1491)+ * `HasBiSignalDefault`: constraint to Clash.Signal.BiSignal, `pullUpMode` gives access to the pull-up mode. [#1498](https://github.com/clash-lang/clash-compiler/pull/1498)+ * Match patterns to bitPattern [#1545](https://github.com/clash-lang/clash-compiler/pull/1545)+ * Non TH `fromList` and `unsafeFromList` for Vec. These functions allow Vectors to be created from a list without needing to use template haskell, which is not always desirable. The unsafe version of the function does not compare the length of the list to the desired length of the vector, either truncating or padding with undefined if the lengths differ.+ * `Clash.Explicit.Reset.resetGlitchFilter`: filters glitchy reset signals. Useful when your reset signal is connected to sensitive actuators.+ * Clash can now generate EDAM for using Edalize. This generates edam.py files in all top entities with the configuration for building that entity. Users still need to edit this file to specify the EDA tool to use, and if necessary the device to target (for Quartus, Vivado etc.). [#1386](https://github.com/clash-lang/clash-compiler/issues/1386)+ * `-fclash-aggressive-x-optimization-blackboxes`: when enabled primitives can detect undefined values and change their behavior accordingly. For example, if `register` is used in combination with an undefined reset value, it will leave out the reset logic entirely. Related issue: [#1506](https://github.com/clash-lang/clash-compiler/issues/1506).+ * Automaton-based interface to simulation, to allow interleaving of cyle-by-cycle simulation and external effects [#1261](https://github.com/clash-lang/clash-compiler/pull/1261)+++New internal features:+ * `constructProduct` and `deconstructProduct` in `Clash.Primitives.DSL`. Like `tuple` and `untuple`, but on arbitrary product types.+ * Support for multi result primitives. Primitives can now assign their results to multiple variables. This can help to work around synthesis tools limits in some cases. See [#1560](https://github.com/clash-lang/clash-compiler/pull/1560).+ * Added a rule for missing `Int` comparisons in `GHC.Classes` in the compile time evaluator. [#1648](https://github.com/clash-lang/clash-compiler/issues/1648)+ * Clash now creates a mapping from domain names to configurations in `LoadModules`. [#1405](https://github.com/clash-lang/clash-compiler/pull/1405)+ * The convenience functions in `Clash.Primitives.DSL` now take a list of HDLs, instead of just one.+ * `Clash.Netlist.Id` overhauls the way identifiers are generated in the Netlist part of Clash.+ * Added `defaultWithAction` to Clash-as-a-library API to work around/fix issues such as [#1686](https://github.com/clash-lang/clash-compiler/issues/1686)+ * Manifest files now list files and components in an reverse topological order. This means it can be used when calling EDA tooling without causing compilation issues.++Deprecated:+ * `Clash.Prelude.DataFlow`: see [#1490](https://github.com/clash-lang/clash-compiler/pull/1490). In time, its functionality will be replaced by [clash-protocols](https://github.com/clash-lang/clash-protocols).++Removed:+ * The deprecated function `freqCalc` has been removed.+ ## 1.2.5 *November 9th 2020* Fixed: * The normalizeType function now fully normalizes types which require calls to@@ -13,6 +98,9 @@ * Clash now uses correct function names in manifest and sdc files [#1533](https://github.com/clash-lang/clash-compiler/issues/1533) * Clash no longer produces erroneous HDL in very specific cases [#1536](https://github.com/clash-lang/clash-compiler/issues/1536) * Usage of `fold` inside other HO primitives (e.g., `map`) no longer fails [#1524](https://github.com/clash-lang/clash-compiler/issues/1524)++Changed:+ * Due to difficulties using `resetSynchronizer` we've decided to make this function always insert a synchronizer. See: [#1528](https://github.com/clash-lang/clash-compiler/issues/1528). ## 1.2.4 *July 28th 2020* * Changed:
clash-ghc.cabal view
@@ -1,7 +1,7 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.2.5-Synopsis: CAES Language for Synchronous Hardware+Version: 1.4.0+Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its syntax and semantics from the functional programming language Haskell. The@@ -66,6 +66,12 @@ default: False manual: True +flag experimental-evaluator+ description:+ Use the new partial evaluator (experimental; may break)+ default: False+ manual: True+ executable clash Main-Is: src-ghc/Batch.hs Build-Depends: base, clash-ghc@@ -109,10 +115,15 @@ if impl(ghc >= 8.6) default-extensions: NoStarIsType + if flag(experimental-evaluator)+ cpp-options: -DEXPERIMENTAL_EVALUATOR+ library import: common-options HS-Source-Dirs: src-ghc, src-bin-common- if impl(ghc >= 8.10.0)+ if impl(ghc >= 9.0.0)+ HS-Source-Dirs: src-bin-9.0+ elif impl(ghc >= 8.10.0) HS-Source-Dirs: src-bin-8.10 elif impl(ghc >= 8.8.0) HS-Source-Dirs: src-bin-881@@ -139,45 +150,50 @@ Cabal, containers >= 0.5.4.0 && < 0.7, directory >= 1.2 && < 1.4,+ extra >= 1.6 && < 1.8, filepath >= 1.3 && < 1.5,- ghc >= 8.4.0 && < 8.11,+ ghc >= 8.4.0 && < 9.1, process >= 1.2 && < 1.7, hashable >= 1.1.2.3 && < 1.4, haskeline >= 0.7.0.3 && < 0.9,- lens >= 4.10 && < 4.20,+ lens >= 4.10 && < 5.1.0, mtl >= 2.1.1 && < 2.3, split >= 0.2.3 && < 0.3, text >= 1.2.2 && < 1.3, transformers >= 0.5.2.0 && < 0.6, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.2.5,- clash-prelude == 1.2.5,+ clash-lib == 1.4.0,+ clash-prelude == 1.4.0, concurrent-supply >= 0.1.7 && < 0.2,- ghc-typelits-extra >= 0.3.3 && < 0.5,- ghc-typelits-knownnat >= 0.7.2 && < 0.8,- ghc-typelits-natnormalise >= 0.7.2 && < 0.8,+ ghc-typelits-extra >= 0.3.2 && < 0.5,+ ghc-typelits-knownnat >= 0.6 && < 0.8,+ ghc-typelits-natnormalise >= 0.6 && < 0.8, deepseq >= 1.3.0.2 && < 1.5, time >= 1.4.0.1 && < 1.12,- ghc-boot >= 8.4.0 && < 8.11,- ghc-prim >= 0.3.1.0 && < 0.7,- ghci >= 8.4.0 && < 8.11,+ ghc-boot >= 8.4.0 && < 9.1,+ ghc-prim >= 0.3.1.0 && < 0.8,+ ghci >= 8.4.0 && < 9.1, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0,- integer-gmp >= 1.0.1.0 && < 2.0, primitive >= 0.5.0.1 && < 1.0,- template-haskell >= 2.8.0.0 && < 2.17,+ template-haskell >= 2.8.0.0 && < 2.18, utf8-string >= 1.0.0.0 && < 1.1.0.0, vector >= 0.11 && < 1.0 if impl(ghc >= 8.10.0) Build-Depends: exceptions >= 0.10.4 && < 0.11, + if impl(ghc >= 9.0.0)+ Build-Depends: ghc-bignum >= 1.0 && < 1.1+ else+ Build-Depends: integer-gmp >= 1.0.1.0 && < 2.0+ if flag(use-ghc-paths) Build-Depends: ghc-paths CPP-Options: -DUSE_GHC_PATHS=1 if os(windows)- Build-Depends: Win32 >= 2.3.1 && < 2.10+ Build-Depends: Win32 >= 2.3.1 && < 2.12 else Build-Depends: unix >= 2.7.1 && < 2.9 @@ -190,9 +206,15 @@ -- exposed for use by the benchmarks Clash.GHC.Evaluator+ Clash.GHC.Evaluator.Primitive Clash.GHC.GenerateBindings Clash.GHC.LoadModules Clash.GHC.NetlistTypes++ Clash.GHC.PartialEval+ Clash.GHC.PartialEval.Eval+ Clash.GHC.PartialEval.Quote+ Clash.GHC.PartialEval.Primitive Clash.GHCi.Common
src-bin-8.10/Clash/GHCi/UI.hs view
@@ -98,6 +98,7 @@ import Data.Array import qualified Data.ByteString.Char8 as BS import Data.Char+import Data.Coerce import Data.Function import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf,@@ -145,16 +146,24 @@ -- clash additions import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver import Clash.Driver.Types (ClashOpts(..))++#if EXPERIMENTAL_EVALUATOR+import Clash.GHC.PartialEval+#else import Clash.GHC.Evaluator+#endif+ import Clash.GHC.GenerateBindings import Clash.GHC.NetlistTypes import Clash.GHCi.Common import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion, reportTimeDiff) import qualified Data.Time.Clock as Clock import qualified Paths_clash_ghc@@ -2138,7 +2147,7 @@ exceptT = ExceptT . pure makeHDL' :: Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend) -> IORef ClashOpts -> [FilePath] -> InputT GHCi ()@@ -2171,7 +2180,7 @@ env <- GHC.getSession liftIO (unload env []) -- Finally generate the HDL- makeHDL backend opts srcs+ makeHDL backend (return ()) opts srcs recover dflags = do _ <- GHC.setSessionDynFlags dflags@@ -2179,11 +2188,12 @@ makeHDL :: GHC.GhcMonad m => Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> GHC.Ghc () -> IORef ClashOpts -> [FilePath] -> m ()-makeHDL backend optsRef srcs = do+makeHDL backend startAction optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef@@ -2193,7 +2203,9 @@ syn = opt_hdlSyn opts1 color = opt_color opts1 esc = opt_escapedIds opts1+ lw = opt_lowerCaseBasicIds opts1 frcUdf = opt_forceUndefined opts1+ xOptBB = opt_aggressiveXOptBB opts1 hdl = Clash.Backend.hdlKind backend' -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags@@ -2206,7 +2218,7 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc frcUdf+ backend' = backend iw syn esc lw frcUdf (coerce xOptBB) checkMonoLocalBinds dflags checkImportDirs opts0 idirs@@ -2216,8 +2228,9 @@ forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]- (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-- generateBindings color primDirs idirs dbs hdl src (Just dflags)+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-+ generateBindings startAction color primDirs idirs dbs hdl src (Just dflags)+ let getMain = getMainTopEntity src bindingsMap topEntities mainTopEntity <- traverse getMain (GHC.mainFunIs dflags) prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime@@ -2227,13 +2240,18 @@ -- Generate HDL: Clash.Driver.generateHDL (buildCustomReprs reprs)+ domainConfs bindingsMap (Just backend') primMap tcm tupTcm (ghcTypeToHWType iw fp)- primEvaluator+#if EXPERIMENTAL_EVALUATOR+ ghcEvaluator+#else+ evaluator+#endif topEntities mainTopEntity opts2
src-bin-8.10/Clash/Main.hs view
@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -module Clash.Main (defaultMain) where+module Clash.Main (defaultMain, defaultMainWithAction) where -- The official GHC API import qualified GHC@@ -85,13 +85,13 @@ -- clash additions import Paths_clash_ghc-import Clash.GHCi.Common (checkClashDynamic) import Clash.GHCi.UI (makeHDL) import Exception (gcatch) import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Version (showVersion) import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState)@@ -99,6 +99,7 @@ (ClashOpts (..), defClashOpts) import Clash.GHC.ClashFlags import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion) import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import Clash.GHC.Util (handleClashException)@@ -116,7 +117,10 @@ -- GHC's command-line interface defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do+defaultMain = defaultMainWithAction (return ())++defaultMainWithAction :: Ghc () -> [String] -> IO ()+defaultMainWithAction startAction = flip withArgs $ do initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering@@ -160,7 +164,6 @@ GHC.runGhc (Just libDir) $ do dflags <- GHC.getSessionDynFlags- liftIO (checkClashDynamic dflags) let dflagsExtra = setWantedLanguageExtensions dflags ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"@@ -182,12 +185,13 @@ ShowGhciUsage -> showGhciUsage dflagsExtra1 PrintWithDynFlags f -> putStrLn (f dflagsExtra1) Right postLoadMode ->- main' postLoadMode dflagsExtra1 argv3 flagWarnings r+ main' postLoadMode dflagsExtra1 argv3 flagWarnings startAction r main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]+ -> Ghc () -> IORef ClashOpts -> Ghc ()-main' postLoadMode dflags0 args flagWarnings clashOpts = do+main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not@@ -303,7 +307,7 @@ GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do clashOpts' <- liftIO (readIORef clashOpts)- let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ let clash fun = gcatch (fun startAction clashOpts srcs) (handleClashException dflags6 clashOpts') case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs@@ -999,18 +1003,20 @@ ----------------------------------------------------------------------------- -- HDL Generation -makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)- -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()-makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")-makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs+makeHDL'+ :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc () -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend startAction r srcs = makeHDL backend startAction r $ fmap fst srcs -makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc () makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState) -makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc () makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState) -makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc () makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState) -- -----------------------------------------------------------------------------
src-bin-841/Clash/GHCi/UI.hs view
@@ -91,6 +91,7 @@ import Data.Array import qualified Data.ByteString.Char8 as BS import Data.Char+import Data.Coerce import Data.Function import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,@@ -134,16 +135,24 @@ -- clash additions import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver import Clash.Driver.Types (ClashOpts(..))++#if EXPERIMENTAL_EVALUATOR+import Clash.GHC.PartialEval+#else import Clash.GHC.Evaluator+#endif+ import Clash.GHC.GenerateBindings import Clash.GHC.NetlistTypes import Clash.GHCi.Common import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion, reportTimeDiff) import qualified Data.Time.Clock as Clock import qualified Paths_clash_ghc@@ -1919,7 +1928,7 @@ makeHDL' :: Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend) -> IORef ClashOpts -> [FilePath] -> InputT GHCi ()@@ -1952,7 +1961,7 @@ env <- GHC.getSession liftIO (unload env []) -- Finally generate the HDL- makeHDL backend opts srcs+ makeHDL backend (return ()) opts srcs recover dflags = do _ <- GHC.setSessionDynFlags dflags@@ -1961,11 +1970,12 @@ makeHDL :: GHC.GhcMonad m => Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> GHC.Ghc () -> IORef ClashOpts -> [FilePath] -> m ()-makeHDL backend optsRef srcs = do+makeHDL backend startAction optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef@@ -1975,7 +1985,9 @@ syn = opt_hdlSyn opts1 color = opt_color opts1 esc = opt_escapedIds opts1+ lw = opt_lowerCaseBasicIds opts1 frcUdf = opt_forceUndefined opts1+ xOptBB = opt_aggressiveXOptBB opts1 hdl = Clash.Backend.hdlKind backend' -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags@@ -1988,7 +2000,7 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc frcUdf+ backend' = backend iw syn esc lw frcUdf (coerce xOptBB) checkMonoLocalBinds dflags checkImportDirs opts0 idirs@@ -1998,8 +2010,8 @@ forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]- (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-- generateBindings color primDirs idirs dbs hdl src (Just dflags)+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-+ generateBindings startAction color primDirs idirs dbs hdl src (Just dflags) let getMain = getMainTopEntity src bindingsMap topEntities mainTopEntity <- traverse getMain (GHC.mainFunIs dflags) prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime@@ -2009,26 +2021,31 @@ -- Generate HDL: Clash.Driver.generateHDL (buildCustomReprs reprs)+ domainConfs bindingsMap (Just backend') primMap tcm tupTcm (ghcTypeToHWType iw fp)- primEvaluator+#if EXPERIMENTAL_EVALUATOR+ ghcEvaluator+#else+ evaluator+#endif topEntities mainTopEntity opts2 (startTime,prepTime) makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
src-bin-841/Clash/Main.hs view
@@ -11,7 +11,7 @@ -- ----------------------------------------------------------------------------- -module Clash.Main (defaultMain) where+module Clash.Main (defaultMain, defaultMainWithAction) where -- For Int/Word size #include "MachDeps.h"@@ -81,19 +81,20 @@ -- clash additions import Paths_clash_ghc-import Clash.GHCi.Common (checkClashDynamic) import Clash.GHCi.UI (makeHDL) import Exception (gcatch) import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Version (showVersion) import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import Clash.Driver.Types (ClashOpts (..), defClashOpts) import Clash.GHC.ClashFlags import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion) import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import Clash.GHC.Util (handleClashException)@@ -111,7 +112,10 @@ -- GHC's command-line interface defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do+defaultMain = defaultMainWithAction (return ())++defaultMainWithAction :: Ghc () -> [String] -> IO ()+defaultMainWithAction startAction = flip withArgs $ do initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering@@ -169,7 +173,6 @@ GHC.runGhc (Just libDir) $ do dflags <- GHC.getSessionDynFlags- liftIO (checkClashDynamic dflags) let dflagsExtra = setWantedLanguageExtensions dflags ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"@@ -191,12 +194,12 @@ ShowGhciUsage -> showGhciUsage dflagsExtra1 PrintWithDynFlags f -> putStrLn (f dflagsExtra1) Right postLoadMode ->- main' postLoadMode dflagsExtra1 argv3 flagWarnings r+ main' postLoadMode dflagsExtra1 argv3 flagWarnings startAction r main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]- -> IORef ClashOpts+ -> Ghc () -> IORef ClashOpts -> Ghc ()-main' postLoadMode dflags0 args flagWarnings clashOpts = do+main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not@@ -298,7 +301,7 @@ GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do clashOpts' <- liftIO (readIORef clashOpts)- let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ let clash fun = gcatch (fun startAction clashOpts srcs) (handleClashException dflags6 clashOpts') case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs@@ -976,19 +979,23 @@ ----------------------------------------------------------------------------- -- VHDL Generation -makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)- -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()-makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")-makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs+makeHDL'+ :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc () -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend startAction r srcs = makeHDL backend startAction r $ fmap fst srcs -makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)+makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState) -makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)+makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState) -makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)+makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
src-bin-861/Clash/GHCi/UI.hs view
@@ -94,6 +94,7 @@ import Data.Array import qualified Data.ByteString.Char8 as BS import Data.Char+import Data.Coerce import Data.Function import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,@@ -140,16 +141,24 @@ -- clash additions import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver import Clash.Driver.Types (ClashOpts(..))++#if EXPERIMENTAL_EVALUATOR+import Clash.GHC.PartialEval+#else import Clash.GHC.Evaluator+#endif+ import Clash.GHC.GenerateBindings import Clash.GHC.NetlistTypes import Clash.GHCi.Common import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion, reportTimeDiff) import qualified Data.Time.Clock as Clock import qualified Paths_clash_ghc@@ -1969,7 +1978,7 @@ exceptT = ExceptT . pure makeHDL' :: Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend) -> IORef ClashOpts -> [FilePath] -> InputT GHCi ()@@ -2002,7 +2011,7 @@ env <- GHC.getSession liftIO (unload env []) -- Finally generate the HDL- makeHDL backend opts srcs+ makeHDL backend (return ()) opts srcs recover dflags = do _ <- GHC.setSessionDynFlags dflags@@ -2010,11 +2019,12 @@ makeHDL :: GHC.GhcMonad m => Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> GHC.Ghc () -> IORef ClashOpts -> [FilePath] -> m ()-makeHDL backend optsRef srcs = do+makeHDL backend startAction optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef@@ -2024,7 +2034,9 @@ syn = opt_hdlSyn opts1 color = opt_color opts1 esc = opt_escapedIds opts1+ lw = opt_lowerCaseBasicIds opts1 frcUdf = opt_forceUndefined opts1+ xOptBB = opt_aggressiveXOptBB opts1 hdl = Clash.Backend.hdlKind backend' -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags@@ -2037,7 +2049,7 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc frcUdf+ backend' = backend iw syn esc lw frcUdf (coerce xOptBB) checkMonoLocalBinds dflags checkImportDirs opts0 idirs@@ -2047,8 +2059,8 @@ forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]- (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-- generateBindings color primDirs idirs dbs hdl src (Just dflags)+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-+ generateBindings startAction color primDirs idirs dbs hdl src (Just dflags) let getMain = getMainTopEntity src bindingsMap topEntities mainTopEntity <- traverse getMain (GHC.mainFunIs dflags) prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime@@ -2058,26 +2070,31 @@ -- Generate HDL: Clash.Driver.generateHDL (buildCustomReprs reprs)+ domainConfs bindingsMap (Just backend') primMap tcm tupTcm (ghcTypeToHWType iw fp)- primEvaluator+#if EXPERIMENTAL_EVALUATOR+ ghcEvaluator+#else+ evaluator+#endif topEntities mainTopEntity opts2 (startTime,prepTime) makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
src-bin-861/Clash/Main.hs view
@@ -11,7 +11,7 @@ -- ----------------------------------------------------------------------------- -module Clash.Main (defaultMain) where+module Clash.Main (defaultMain, defaultMainWithAction) where -- For Int/Word size #include "MachDeps.h"@@ -83,13 +83,13 @@ -- clash additions import Paths_clash_ghc-import Clash.GHCi.Common (checkClashDynamic) import Clash.GHCi.UI (makeHDL) import Exception (gcatch) import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Version (showVersion) import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState)@@ -97,6 +97,7 @@ (ClashOpts (..), defClashOpts) import Clash.GHC.ClashFlags import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion) import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import Clash.GHC.Util (handleClashException)@@ -114,7 +115,10 @@ -- GHC's command-line interface defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do+defaultMain = defaultMainWithAction (return ())++defaultMainWithAction :: Ghc () -> [String] -> IO ()+defaultMainWithAction startAction = flip withArgs $ do initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering@@ -160,7 +164,6 @@ GHC.runGhc (Just libDir) $ do dflags <- GHC.getSessionDynFlags- liftIO (checkClashDynamic dflags) let dflagsExtra = setWantedLanguageExtensions dflags ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"@@ -182,12 +185,12 @@ ShowGhciUsage -> showGhciUsage dflagsExtra1 PrintWithDynFlags f -> putStrLn (f dflagsExtra1) Right postLoadMode ->- main' postLoadMode dflagsExtra1 argv3 flagWarnings r+ main' postLoadMode dflagsExtra1 argv3 flagWarnings startAction r main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]- -> IORef ClashOpts+ -> Ghc () -> IORef ClashOpts -> Ghc ()-main' postLoadMode dflags0 args flagWarnings clashOpts = do+main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not@@ -289,7 +292,7 @@ GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do clashOpts' <- liftIO (readIORef clashOpts)- let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ let clash fun = gcatch (fun startAction clashOpts srcs) (handleClashException dflags6 clashOpts') case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs@@ -970,19 +973,19 @@ ----------------------------------------------------------------------------- -- HDL Generation -makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)- -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()-makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")-makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs+makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc () -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend startAction r srcs = makeHDL backend startAction r $ fmap fst srcs -makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)+makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState) -makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)+makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState) -makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)+makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
src-bin-881/Clash/GHCi/UI.hs view
@@ -95,6 +95,7 @@ import Data.Array import qualified Data.ByteString.Char8 as BS+import Data.Coerce import Data.Char import Data.Function import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )@@ -142,16 +143,24 @@ -- clash additions import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver import Clash.Driver.Types (ClashOpts(..))++#if EXPERIMENTAL_EVALUATOR+import Clash.GHC.PartialEval+#else import Clash.GHC.Evaluator+#endif+ import Clash.GHC.GenerateBindings import Clash.GHC.NetlistTypes import Clash.GHCi.Common import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion, reportTimeDiff) import qualified Data.Time.Clock as Clock import qualified Paths_clash_ghc@@ -2060,7 +2069,7 @@ exceptT = ExceptT . pure makeHDL' :: Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend) -> IORef ClashOpts -> [FilePath] -> InputT GHCi ()@@ -2093,7 +2102,7 @@ env <- GHC.getSession liftIO (unload env []) -- Finally generate the HDL- makeHDL backend opts srcs+ makeHDL backend (return ()) opts srcs recover dflags = do _ <- GHC.setSessionDynFlags dflags@@ -2101,11 +2110,12 @@ makeHDL :: GHC.GhcMonad m => Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc () -> IORef ClashOpts -> [FilePath] -> m ()-makeHDL backend optsRef srcs = do+makeHDL backend startAction optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef@@ -2115,7 +2125,9 @@ syn = opt_hdlSyn opts1 color = opt_color opts1 esc = opt_escapedIds opts1+ lw = opt_lowerCaseBasicIds opts1 frcUdf = opt_forceUndefined opts1+ xOptBB = opt_aggressiveXOptBB opts1 hdl = Clash.Backend.hdlKind backend' -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags@@ -2128,7 +2140,7 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc frcUdf+ backend' = backend iw syn esc lw frcUdf (coerce xOptBB) checkMonoLocalBinds dflags checkImportDirs opts0 idirs@@ -2138,8 +2150,8 @@ forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]- (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-- generateBindings color primDirs idirs dbs hdl src (Just dflags)+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-+ generateBindings startAction color primDirs idirs dbs hdl src (Just dflags) let getMain = getMainTopEntity src bindingsMap topEntities mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)@@ -2150,13 +2162,18 @@ -- Generate HDL: Clash.Driver.generateHDL (buildCustomReprs reprs)+ domainConfs bindingsMap (Just backend') primMap tcm tupTcm (ghcTypeToHWType iw fp)- primEvaluator+#if EXPERIMENTAL_EVALUATOR+ ghcEvaluator+#else+ evaluator+#endif topEntities mainTopEntity opts2
src-bin-881/Clash/Main.hs view
@@ -11,7 +11,7 @@ -- ----------------------------------------------------------------------------- -module Clash.Main (defaultMain) where+module Clash.Main (defaultMain, defaultMainWithAction) where -- The official GHC API import qualified GHC@@ -80,13 +80,13 @@ -- clash additions import Paths_clash_ghc-import Clash.GHCi.Common (checkClashDynamic) import Clash.GHCi.UI (makeHDL) import Exception (gcatch) import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Version (showVersion) import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState)@@ -94,6 +94,7 @@ (ClashOpts (..), defClashOpts) import Clash.GHC.ClashFlags import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Netlist.Types (PreserveCase) import Clash.Util (clashLibVersion) import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import Clash.GHC.Util (handleClashException)@@ -111,7 +112,10 @@ -- GHC's command-line interface defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do+defaultMain = defaultMainWithAction (return ())++defaultMainWithAction :: Ghc () -> [String] -> IO ()+defaultMainWithAction startAction = flip withArgs $ do initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering@@ -155,7 +159,6 @@ GHC.runGhc (Just libDir) $ do dflags <- GHC.getSessionDynFlags- liftIO (checkClashDynamic dflags) let dflagsExtra = setWantedLanguageExtensions dflags ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"@@ -177,12 +180,12 @@ ShowGhciUsage -> showGhciUsage dflagsExtra1 PrintWithDynFlags f -> putStrLn (f dflagsExtra1) Right postLoadMode ->- main' postLoadMode dflagsExtra1 argv3 flagWarnings r+ main' postLoadMode dflagsExtra1 argv3 flagWarnings startAction r main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]- -> IORef ClashOpts+ -> Ghc () -> IORef ClashOpts -> Ghc ()-main' postLoadMode dflags0 args flagWarnings clashOpts = do+main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not@@ -298,7 +301,7 @@ GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do clashOpts' <- liftIO (readIORef clashOpts)- let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+ let clash fun = gcatch (fun startAction clashOpts srcs) (handleClashException dflags6 clashOpts') case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs@@ -977,18 +980,20 @@ ----------------------------------------------------------------------------- -- HDL Generation -makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)- -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()-makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files")-makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs+makeHDL'+ :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc () -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend startAction r srcs = makeHDL backend startAction r $ fmap fst srcs -makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc () makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState) -makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc () makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState) -makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc () makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState) -- -----------------------------------------------------------------------------
+ src-bin-9.0/Clash/GHCi/Leak.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module Clash.GHCi.Leak+ ( LeakIndicators+ , getLeakIndicators+ , checkLeakIndicators+ ) where++import Control.Monad+import Data.Bits+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)+import GHC+import GHC.Ptr (Ptr (..))+import Clash.GHCi.Util+import GHC.Driver.Types+import GHC.Utils.Outputable+import GHC.Platform (target32Bit)+import Prelude+import System.Mem+import System.Mem.Weak+import GHC.Types.Unique.DFM++-- Checking for space leaks in GHCi. See #15111, and the+-- -fghci-leak-check flag.++data LeakIndicators = LeakIndicators [LeakModIndicators]++data LeakModIndicators = LeakModIndicators+ { leakMod :: Weak HomeModInfo+ , leakIface :: Weak ModIface+ , leakDetails :: Weak ModDetails+ , leakLinkable :: Maybe (Weak Linkable)+ }++-- | Grab weak references to some of the data structures representing+-- the currently loaded modules.+getLeakIndicators :: HscEnv -> IO LeakIndicators+getLeakIndicators HscEnv{..} =+ fmap LeakIndicators $+ forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do+ leakMod <- mkWeakPtr hmi Nothing+ leakIface <- mkWeakPtr hm_iface Nothing+ leakDetails <- mkWeakPtr hm_details Nothing+ leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable+ return $ LeakModIndicators{..}++-- | Look at the LeakIndicators collected by an earlier call to+-- `getLeakIndicators`, and print messasges if any of them are still+-- alive.+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()+checkLeakIndicators dflags (LeakIndicators leakmods) = do+ performGC+ forM_ leakmods $ \LeakModIndicators{..} -> do+ deRefWeak leakMod >>= \case+ Nothing -> return ()+ Just hmi ->+ report ("HomeModInfo for " +++ showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)+ deRefWeak leakIface >>= report "ModIface"+ deRefWeak leakDetails >>= report "ModDetails"+ forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"+ where+ report :: String -> Maybe a -> IO ()+ report _ Nothing = return ()+ report msg (Just a) = do+ addr <- anyToPtr a+ putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " +++ show (maskTagBits addr))++ tagBits+ | target32Bit (targetPlatform dflags) = 2+ | otherwise = 3++ maskTagBits :: Ptr a -> Ptr a+ maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
+ src-bin-9.0/Clash/GHCi/UI.hs view
@@ -0,0 +1,4579 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI (+ interactiveUI,+ GhciSettings(..),+ defaultGhciSettings,+ ghciCommands,+ ghciWelcomeMsg,+ makeHDL+ ) where++#include "HsVersions.h"++-- GHCi+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )+import Clash.GHCi.UI.Monad hiding ( args, runStmt )+import Clash.GHCi.UI.Tags+import Clash.GHCi.UI.Info+import GHC.Runtime.Debugger++-- The GHC interface+import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.Types+import GHCi.RemoteTypes+import GHCi.BreakArray+import GHC.Driver.Session as DynFlags+import GHC.Utils.Error hiding (traceCmd)+import GHC.Driver.Finder as Finder+import GHC.Driver.Monad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),+ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+ GetDocsFailure(..),+ getModuleGraph, handleSourceError, ms_mod )+import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation)+import GHC.Hs.ImpExp+import GHC.Hs+import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+ setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,+ hsc_dynLinker, hsc_interp, emptyModBreaks )+import GHC.Unit.Module+import GHC.Types.Name+import GHC.Unit.State ( unitIsTrusted, unsafeLookupUnit, unsafeLookupUnitId,+ listVisibleModuleNames, pprFlag, preloadUnits )+import GHC.Iface.Syntax ( showToHeader )+import GHC.Core.Ppr.TyThing+import GHC.Builtin.Names+import GHC.Builtin.Types( stringTyCon_RDR )+import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )+import GHC.Types.SrcLoc as SrcLoc+import qualified GHC.Parser.Lexer as Lexer++import GHC.Data.StringBuffer+import GHC.Utils.Outputable hiding ( printForUser )++import GHC.Runtime.Loader ( initializePlugins )++-- Other random utilities+import GHC.Types.Basic hiding ( isTopLevel )+import GHC.Data.Graph.Directed+import GHC.Utils.Encoding+import GHC.Data.FastString+import GHC.Runtime.Linker+import GHC.Data.Maybe ( orElse, expectJust )+import GHC.Types.Name.Set+import GHC.Utils.Panic hiding ( showException, try )+import GHC.Utils.Misc+import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.Bag (unitBag)++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.Catch as MC+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( elemIndices, find, group, intercalate, intersperse,+ isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )+import qualified Data.Set as S+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as M+import qualified Data.IntMap.Strict as IntMap+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )+import Prelude hiding ((<>))++import GHC.Utils.Exception as Exception hiding (catch, mask, handle)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#if !defined(mingw32_HOST_OS)+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++import Clash.GHCi.Leak++-- clash additions+import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB)+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import qualified Clash.Driver+import Clash.Driver.Types (ClashOpts(..))++#if EXPERIMENTAL_EVALUATOR+import Clash.GHC.PartialEval+#else+import Clash.GHC.Evaluator+#endif++import Clash.GHC.GenerateBindings+import Clash.GHC.NetlistTypes+import Clash.GHCi.Common+import Clash.Netlist.BlackBox.Types (HdlSyn)+import Clash.Netlist.Types (PreserveCase)+import Clash.Util (clashLibVersion, reportTimeDiff)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ shortHelpText = defShortHelpText,+ defPrompt = default_prompt,+ defPromptCont = default_prompt_cont,+ fullHelpText = defFullHelpText+ }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "Clashi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++ " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++ "):\nhttps://clash-lang.org/ :? for help"++ghciCommands :: IORef ClashOpts -> [Command]+ghciCommands opts = map mkCmd [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeBreakpoint),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("continue", keepGoing continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("disable", keepGoing disableCmd, noCompletion),+ ("doc", keepGoing' docCmd, completeIdentifier),+ ("edit", keepGoing' editFile, completeFilename),+ ("enable", keepGoing enableCmd, noCompletion),+ ("etags", keepGoing createETagsFileCmd, completeFilename),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("kind", keepGoing' (kindOfType False), completeIdentifier),+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing moduleCmd, completeSetModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("seti", keepGoing setiCmd, completeSeti),+ ("show", keepGoing showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("unadd", keepGoingPaths unAddModule, completeFilename),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions),+ ("where", keepGoing whereCmd, noCompletion),+ ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),+ ("verilog", keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),+ ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile),+ ("instances", keepGoing' instancesCmd, completeExpression)+ ] ++ map mkCmdHidden [ -- hidden commands+ ("all-types", keepGoing' allTypesCmd),+ ("complete", keepGoing completeCmd),+ ("loc-at", keepGoing' locAtCmd),+ ("type-at", keepGoing' typeAtCmd),+ ("uses", keepGoing' usesCmd)+ ]+ where+ mkCmd (n,a,c) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = False+ , cmdCompletionFunc = c+ }++ mkCmdHidden (n,a) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = True+ , cmdCompletionFunc = noCompletion+ }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+ Left err -> liftIO $ hPutStrLn stderr err+ Right args -> a args+ return False++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++defFullHelpText :: String+defFullHelpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def[!] <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " (!: redefine an existing command name)\n" +++ " :doc <name> display docs for the given name (experimental)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :instances <type> display the class instances available for <type>\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" +++ " :unadd <module> ... remove module(s) from the current target set\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " ::<cmd> run the builtin command\n" +++ " :!<command> run the shell command <command>\n" +++ " :vhdl synthesize currently loaded module to vhdl\n" +++ " :vhdl [<module>] synthesize specified modules/files to vhdl\n" +++ " :verilog synthesize currently loaded module to verilog\n" +++ " :verilog [<module>] synthesize specified modules/files to verilog\n" +++ " :systemverilog synthesize currently loaded module to systemverilog\n" +++ " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> ... delete the specified breakpoints\n" +++ " :delete * delete all breakpoints\n" +++ " :disable <number> ... disable the specified breakpoints\n" +++ " :disable * disable all breakpoints\n" +++ " :enable <number> ... enable the specified breakpoints\n" +++ " :enable * enable all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set local-config { source | ignore }\n" +++ " set whether to source .ghci in current dir\n" +++ " (loading untrusted config is a security issue)\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>\n" +++ " set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show targets show the current set of targets\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n" +++ " The User's Guide has more information. An online copy can be found here:\n" +++ "\n" +++ " https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if defined(mingw32_HOST_OS)+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "clashi> "+default_prompt_cont = generatePromptFunctionFromString "| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ -- See note [Changing language extensions for interactive evaluation] #10857+ dflags <- getDynFlags+ let dflags' = (xopt_set_unlessExplSpec+ LangExt.ExtendedDefaultRules xopt_set)+ . (xopt_set_unlessExplSpec+ LangExt.MonomorphismRestriction xopt_unset)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ -- Ensure we don't override the user's log action lest we break+ -- -ddump-json (#14078)+ progDynFlags { log_action = ghciLogAction (log_action progDynFlags)+ lastErrLocationsRef }++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import = simpleImportDecl preludeModuleName+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = defPrompt config,+ prompt_cont = defPromptCont config,+ stop = default_stop,+ editor = default_editor,+ options = [],+ localConfig = SourceLocalConfig,+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = IntMap.empty,+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmd_wrapper = (cmdSuccess =<<),+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering+ }++ return ()++{-+Note [Changing language extensions for interactive evaluation]+--------------------------------------------------------------+GHCi maintains two sets of options:++- The "loading options" apply when loading modules+- The "interactive options" apply when evaluating expressions and commands+ typed at the GHCi prompt.++The loading options are mostly created in ghc/Main.hs:main' from the command+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options+are copied to the interactive options.++These interactive options (but not the loading options!) are supplemented+unconditionally by setting ExtendedDefaultRules ON and+MonomorphismRestriction OFF. The unconditional setting of these options+eventually overwrite settings already specified at the command line.++Therefore instead of unconditionally setting ExtendedDefaultRules and+NoMonomorphismRestriction for the interactive options, we use the function+'xopt_set_unlessExplSpec' to first check whether the extension has already+specified at the command line.++The ghci config file has not yet been processed.+-}++resetLastErrorLocations :: GhciMonad m => m ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction+ghciLogAction old_log_action lastErrLocations+ dflags flag severity srcSpan msg = do+ old_log_action dflags flag severity srcSpan msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp _ -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "clash")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "clashi.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".clashi"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ processedCfgs <- if ignore_dot_ghci+ then pure []+ else do+ userCfgs <- do+ paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]+ checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths+ liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths++ localCfg <- do+ let path = ".clashi"+ ok <- liftIO $ checkFileAndDirPerms path+ if ok then liftIO $ canonicalizePath' path else pure Nothing++ mapM_ sourceConfigFile userCfgs+ -- Process the global and user .ghci+ -- (but not $CWD/.ghci or CLI args, yet)++ behaviour <- localConfig <$> getGHCiState++ processedLocalCfg <- case localCfg of+ Just path | path `notElem` userCfgs ->+ -- don't read .ghci twice if CWD is $HOME+ case behaviour of+ SourceLocalConfig -> localCfg <$ sourceConfigFile path+ IgnoreLocalConfig -> pure Nothing+ _ -> pure Nothing++ pure $ maybe id (:) processedLocalCfg userCfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)++ mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs+ -- Dedup, and remove any configs we already processed.+ -- Importantly, if $PWD/.ghci was ignored due to configuration,+ -- explicitly specifying it does cause it to be processed.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- liftIO (hIsTerminalDevice stdin)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ -- Set different defaulting rules (See #280)+ runGHCiExpressions+ ["default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"]++ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."++runGHCiExpressions :: [String] -> GHCi ()+runGHCiExpressions exprs = do+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO $ getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> return (Just (currentDirectory </> ".ghci_history"))+ (True, _) -> liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)+ _ -> return Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: GhciMonad m => m ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: GhciMonad m => Handle -> m (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString m) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+ | not (all isSpace beforeOpen) = ("", "")+ | null sinceOpen = ("", "")+ | null sinceClosed = ("", "")+ | null cmd = ("", "")+ | otherwise = (cmd, tail sinceClosed)+ where+ (beforeOpen, sinceOpen) = span (/='(') s+ (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ ("", "") -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS modules_names line =+ processString promptS+ where+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = hsep $ map text modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ respond <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ (head list_words) (tail list_words) ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr err+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ where+ (cmd, afterClosed) = parseCallEscape xs+ list_words = words cmd+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GhciMonad m => m (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ names <- GHC.parseName ipFun+ let name = case names of+ name':_ -> name'+ [] -> panic "installInteractivePrint"+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi ()+runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do+ b <- handle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return ()+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> do+ st <- getGHCiState+ ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail $+ cmd_wrapper st $ doCommand c+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ GHC.printException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `MC.finally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi CommandResult++ -- command+ doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do+ (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd+ let processResult True = Nothing+ processResult False = Just True+ return $ CommandComplete stmt' (processResult <$> result) stats++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return CommandIncomplete+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $+ CommandComplete ml_stmt (Just . runSuccess <$> result) stats+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ CommandComplete stmt' (Just . runSuccess <$> result) stats++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout+ :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: GhciMonad m => [String] -> m ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)+runStmt input step = do+ pflags <- Lexer.mkParserFlags <$> GHC.getInteractiveDynFlags+ -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`+ -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The+ -- declarations and statements are not affected.+ -- See Note [Deferred type errors in GHCi] in GHC.Tc.Module+ st <- getGHCiState+ let source = progname st+ let line = line_number st++ if | GHC.isStmt pflags input -> do+ hsc_env <- GHC.getSession+ mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))+ case mb_stmt of+ Nothing ->+ -- empty statement / comment+ return (Just exec_complete)+ Just stmt ->+ run_stmt stmt++ | GHC.isImport pflags input -> run_import++ -- Every import declaration should be handled by `run_import`. As GHCi+ -- in general only accepts one command at a time, we simply throw an+ -- exception when the input contains multiple commands of which at least+ -- one is an import command (see #10663).+ | GHC.hasImport pflags input -> throwGhcException+ (CmdLineError "error: expecting a single import declaration")++ -- Otherwise assume a declaration (or a list of declarations)+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> do+ hsc_env <- GHC.getSession+ decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)+ run_decls decls+ where+ exec_complete = GHC.ExecComplete (Right []) 0++ run_import = do+ addImportToContext input+ return (Just exec_complete)++ run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)+ run_stmt stmt = do+ m_result <- GhciMonad.runStmt stmt input step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt (const True) result++ -- `x = y` (a declaration) should be treated as `let x = y` (a statement).+ -- The reason is because GHCi wasn't designed to support `x = y`, but then+ -- b98ff3 (#7253) added support for it, except it did not do a good job and+ -- caused problems like:+ --+ -- - not adding the binders defined this way in the necessary places caused+ -- `x = y` to not work in some cases (#12091).+ -- - some GHCi command crashed after `x = y` (#15721)+ -- - warning generation did not work for `x = y` (#11606)+ -- - because `x = y` is a declaration (instead of a statement) differences+ -- in generated code caused confusion (#16089)+ --+ -- Instead of dealing with all these problems individually here we fix this+ -- mess by just treating `x = y` as `let x = y`.+ run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)+ -- Only turn `FunBind` and `VarBind` into statements, other bindings+ -- (e.g. `PatBind`) need to stay as decls.+ run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)+ run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)+ -- Note that any `x = y` declarations below will be run as declarations+ -- instead of statements (e.g. `...; x = y; ...`)+ run_decls decls = do+ -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls' decls+ forM m_result $ \result ->+ afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)++ mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs+ mk_stmt loc bind =+ let l = L loc+ in l (LetStmt noExtField (l (HsValBinds noExtField (ValBinds noExtField (unitBag (l bind)) []))))++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: GhciMonad m+ => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation :: GhciMonad m+ => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()+printStoppedAtBreakInfo res names = do+ printForUser $ pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 =+ (compare `on` getOccString) n1 n2 `thenCmp`+ (SrcLoc.leftmost_smallest `on` getSrcSpan) n1 n2++printTypeOfName :: GHC.GhcMonad m => Name -> m ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lookupCommand cmd+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: MonadIO m => String -> m Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: GhciMonad m => String -> m (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: GhciMonad m => String -> m (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOptOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++-- This predicate is for prefix match with a command-body and+-- suffix match with an option, such as `!`.+-- The current implementation assumes only the `!` character+-- as the option delimiter.+-- See also #17345+isPrefixOptOf :: String -> String -> Bool+isPrefixOptOf s x = let (body, opt) = break (== '!') s+ in (body `isPrefixOf` x) && (opt `isSuffixOf` x)++getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ hsc_env <- GHC.getSession+ Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: MonadIO m => m () -> String -> m ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: GhciMonad m => String -> m ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: GHC.GhcMonad m => Bool -> String -> m ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+ (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts, docs)+ = docs+ $$ pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: GhciMonad m => String -> m ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: GhciMonad m => String -> m ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: GhciMonad m => [String] -> String -> m ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: GhciMonad m => String -> m ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null $ GHC.mgModSummaries graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ -- delete targets and all eventually defined breakpoints (#1620)+ clearAllTargets+ setContextAfterLoad False []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behaviour with and without -fexternal-interpreter)+ hsc_env <- GHC.getSession+ case hsc_interp hsc_env of+ Just (ExternalInterp {}) -> do+ fhv <- compileGHCiExpr $+ "System.Directory.setCurrentDirectory " ++ show dir'+ liftIO $ evalIO hsc_env fhv+ _ -> pure ()++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: GhciMonad m => String -> m ()+editFile str =+ do file <- if null str then chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occurred during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHC.GhcMonad m => m String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <-+ GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()+defineMacro _ (':':_) = liftIO $ putStrLn+ "macro name cannot start with a colon"+defineMacro _ ('!':_) = liftIO $ putStrLn+ "macro name cannot start with an exclamation mark"+ -- little code duplication allows to grep error msg+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ isCommand <- isJust <$> lookupCommand' macro_name+ let check_newname+ | macro_name `elem` defined = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))+ | isCommand = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))+ | otherwise = return ()+ hint = " Use ':def!' to overwrite."++ unless overwrite check_newname+ -- compile the expression+ handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy = nlHsTyVar stringTyCon_RDR+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkLHsSigWcType (nlHsFunTy stringTy ioM)+ new_expr = L (getLoc expr) $ ExprWithTySig noExtField body tySig+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+ in s { ghci_macros = newCmd : filtered }++runMacro+ :: GhciMonad m+ => GHC.ForeignHValue -- String -> IO String+ -> String+ -> m Bool+runMacro fun s = do+ hsc_env <- GHC.getSession+ str <- liftIO $ evalStringToIOString hsc_env fun s+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: GhciMonad m => String -> m ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: GhciMonad m => String -> m ()+cmdCmd str = handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ hsc_env <- GHC.getSession+ cmds <- liftIO $ evalString hsc_env hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar stringTyCon_RDR+ ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkLHsSigWcType (nlHsFunTy ghciM ioM)+ return $ noLoc $ ExprWithTySig noExtField body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: GhciMonad m => String -> m ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False++-----------------------------------------------------------------------------+-- :doc++docCmd :: GHC.GhcMonad m => String -> m ()+docCmd "" =+ throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")+docCmd s = do+ -- TODO: Maybe also get module headers for module names+ names <- GHC.parseName s+ e_docss <- mapM GHC.getDocs names+ sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss+ let sdocs' = vcat (intersperse (text "") sdocs)+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'++-- TODO: also print arg docs.+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc+pprDocs (mb_decl_docs, _arg_docs) =+ maybe+ (text "<has no documentation>")+ (text . unpackHDS)+ mb_decl_docs++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc+handleGetDocsFailure no_docs = do+ dflags <- getDynFlags+ let msg = showPpr dflags no_docs+ throwGhcException $ case no_docs of+ NameHasNoModule {} -> Sorry msg+ NoDocsInIface {} -> InstallationError msg+ InteractiveName -> ProgramError msg++-----------------------------------------------------------------------------+-- :instances++instancesCmd :: String -> InputT GHCi ()+instancesCmd "" =+ throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")+instancesCmd s = do+ handleSourceError GHC.printException $ do+ ty <- GHC.parseInstanceHead s+ res <- GHC.getInstancesForType ty++ printForUser $ vcat $ map ppr res++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a+wrapDeferTypeErrors load =+ MC.bracket+ (do+ -- Force originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule fs = do+ (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)+ either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: GhciMonad m => [FilePath] -> m ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ hsc_env <- GHC.getSession++ -- Grab references to the currently loaded modules so that we can+ -- see if they leak.+ let !dflags = hsc_dflags hsc_env+ leak_indicators <- if gopt Opt_GhciLeakCheck dflags+ then liftIO $ getLeakIndicators hsc_env+ else return (panic "no leak indicators")++ -- unload first+ _ <- GHC.abandonAll+ clearAllTargets++ GHC.setTargets targets+ success <- doLoadAndCollectInfo False LoadAllTargets+ when (gopt Opt_GhciLeakCheck dflags) $+ liftIO $ checkLeakIndicators dflags leak_indicators+ return success++-- | @:add@ command+addModule :: GhciMonad m => [FilePath] -> m ()+addModule files = do+ revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ targets' <- filterM checkTarget targets+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]+ mapM_ GHC.addTarget targets'+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()+ where+ checkTarget :: GHC.GhcMonad m => Target -> m Bool+ checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+ checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++ checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool+ checkTargetModule m = do+ hsc_env <- GHC.getSession+ result <- liftIO $+ Finder.findImportedModule hsc_env m (Just (fsLit "this"))+ case result of+ Found _ _ -> return True+ _ -> (liftIO $ putStrLn $+ "Module " ++ moduleNameString m ++ " not found") >> return False++ checkTargetFile :: String -> IO Bool+ checkTargetFile f = do+ exists <- (doesFileExist f) :: IO Bool+ unless exists $ putStrLn $ "File " ++ f ++ " not found"+ return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: GhciMonad m => String -> m ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+ where+ loadTargets | null m = LoadAllTargets+ | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: GhciMonad m => String -> m ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+ resetOptByteCodeIfUnboxed -- #18955+ doCollectInfo <- isOptionSet CollectInfo++ doLoad retain_context howmuch >>= \case+ Succeeded | doCollectInfo -> do+ mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+ loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ return Succeeded+ flag -> return flag++-- An `OPTIONS_GHC -fbyte-code` pragma at the beginning of a module sets the+-- flag `Opt_ByteCodeIfUnboxed` locally for this module. This stops automatic+-- compilation of this module to object code, if the module uses (or depends+-- on a module using) the UnboxedSums/Tuples extensions.+-- However a GHCi `:set -fbyte-code` command sets the flag Opt_ByteCodeIfUnboxed+-- globally to all modules. This triggered #18955. This function unsets the+-- flag from the global DynFlags before they are copied to the module-specific+-- DynFlags.+-- This is a temporary workaround until GHCi will support unboxed tuples and+-- unboxed sums.+resetOptByteCodeIfUnboxed :: GhciMonad m => m ()+resetOptByteCodeIfUnboxed = do+ dflags <- getDynFlags+ when (gopt Opt_ByteCodeIfUnboxed dflags) $ do+ _ <- GHC.setProgramDynFlags $ gopt_unset dflags Opt_ByteCodeIfUnboxed+ pure ()+ pure ()++doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoad retain_context howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ discardActiveBreakPoints++ resetLastErrorLocations+ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ MC.bracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad+ :: GhciMonad m+ => SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> m ()+afterLoad ok retain_context = do+ revertCAFs -- always revert CAFs on load.+ discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods+ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph = GHC.mkModuleGraph ms+ graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)+ in load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: GhciMonad m+ => Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> m ()+setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports+ :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- MC.try $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isMainUnitModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual++ msg <- if gopt Opt_ShowLoadedModules dflags+ then do+ mod_names <- mapM mod_name mods+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma mod_names) <> text "."+ return $ status <> text ", modules loaded:" <+> mod_commas+ else do+ return $ status <> text ","+ <+> speakNOf (length mods) (text "module") <+> "loaded."++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+ where+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+ return $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath mod)+ -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ dflags <- getDynFlags+ liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++makeHDL' :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi ()+makeHDL' backend opts lst = go =<< case lst of+ srcs@(_:_) -> return srcs+ [] -> do+ modGraph <- GHC.getModuleGraph+ let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing+ return $ case (reverse sortedGraph) of+ ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []+ where+ go srcs = do+ dflags <- GHC.getSessionDynFlags+ goX dflags srcs `MC.finally` recover dflags++ goX dflags srcs = do+ -- Issue #439 step 1+ (dflagsX,_,_) <- parseDynamicFlagsCmdLine dflags+ [ noLoc "-fobject-code" -- For #439+ , noLoc "-fforce-recomp" -- Actually compile to object-code+ , noLoc "-keep-tmp-files" -- To prevent linker errors from+ -- multiple calls to :hdl command+ ]+ _ <- GHC.setSessionDynFlags dflagsX+ reloadModule ""+ -- Issue #439 step 2+ -- Unload any object files+ -- This fixes: https://github.com/clash-lang/clash-compiler/issues/439#issuecomment-522015868+ env <- GHC.getSession+ liftIO (unload env [])+ -- Finally generate the HDL+ makeHDL backend (return ()) opts srcs++ recover dflags = do+ _ <- GHC.setSessionDynFlags dflags+ reloadModule ""++makeHDL :: GHC.GhcMonad m+ => Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc ()+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL backend startAction optsRef srcs = do+ dflags <- GHC.getSessionDynFlags+ liftIO $ do startTime <- Clock.getCurrentTime+ opts0 <- readIORef optsRef+ let opts1 = opts0 { opt_color = useColor dflags }+ let iw = opt_intWidth opts1+ fp = opt_floatSupport opts1+ syn = opt_hdlSyn opts1+ color = opt_color opts1+ esc = opt_escapedIds opts1+ lw = opt_lowerCaseBasicIds opts1+ frcUdf = opt_forceUndefined opts1+ xOptBB = opt_aggressiveXOptBB opts1+ hdl = Clash.Backend.hdlKind backend'+ -- determine whether `-outputdir` was used+ outputDir = do odir <- objectDir dflags+ hidir <- hiDir dflags+ sdir <- stubDir dflags+ ddir <- dumpDir dflags+ if all (== odir) [hidir,sdir,ddir]+ then Just odir+ else Nothing+ idirs = importPaths dflags+ opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)+ , opt_importPaths = idirs}+ backend' = backend iw syn esc lw frcUdf (Clash.Backend.AggressiveXOptBB xOptBB)++ checkMonoLocalBinds dflags+ checkImportDirs opts0 idirs++ primDirs <- Clash.Backend.primDirs backend'++ forM_ srcs $ \src -> do+ -- Generate bindings:+ let dbs = reverse [p | PackageDB (PkgDbPath p) <- packageDBFlags dflags]+ (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-+ generateBindings startAction color primDirs idirs dbs hdl src (Just dflags)++ let getMain = getMainTopEntity src bindingsMap topEntities+ mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)+ prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff++ -- Generate HDL:+ Clash.Driver.generateHDL+ (buildCustomReprs reprs)+ domainConfs+ bindingsMap+ (Just backend')+ primMap+ tcm+ tupTcm+ (ghcTypeToHWType iw fp)+#if EXPERIMENTAL_EVALUATOR+ ghcEvaluator+#else+ evaluator+#endif+ topEntities+ mainTopEntity+ opts2+ (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.++typeOfExpr :: GHC.GhcMonad m => String -> m ()+typeOfExpr str = handleSourceError GHC.printException $ do+ let (mode, expr_str) = case break isSpace str of+ ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+ ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)+ _ -> (GHC.TM_Inst, str)+ ty <- GHC.exprType mode expr_str+ printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ lift $ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: GhciMonad m => String -> m ()+usesCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ uses <- findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: GhciMonad m => String -> m ()+locAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (_,_,sp) <- findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: GhciMonad m => String -> m ()+allTypesCmd _ = runExceptGhcMonad $ do+ infos <- lift $ mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ df <- getDynFlags+ let tyInfo = unwords . words $+ showSDocForUser df alwaysQualify (pprTypeForUser ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ -- End column of RealSrcSpan is the column+ -- after the end of the span.+ (mkRealSrcLoc fs el (ec + 1))++ return (span',trailer)+ where+ readAsInt :: String -> Either SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s)+showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ -- The end column is the column after the end of the span see the+ -- RealSrcSpan module+ ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()+kindOfType norm str = handleSourceError GHC.printException $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: Monad m => String -> m Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words' ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++-- | A version of 'words' that treats sequences enclosed in double quotes as+-- single words and that does not break on backslash-escaped spaces.+-- E.g., 'words\' "\"lorem ipsum\" dolor"' and 'words\' "lorem\\ ipsum dolor"'+-- yield '["lorem ipsum", "dolor"]'.+-- Used to scan for file paths in 'scriptCmd'.+words' :: String -> [String]+words' s = case dropWhile isSpace s of+ "" -> []+ s'@('\"' : _) | [(w, s'')] <- reads s' -> w : words' s''+ s' -> go id s'+ where+ go acc [] = [acc []]+ go acc ('\\' : c : cs) | isSpace c = go (acc . (c :)) cs+ go acc (c : cs) | isSpace c = acc [] : words' cs+ | otherwise = go (acc . (c :)) cs++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: GHC.GhcMonad m => String -> m ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: GHC.GhcMonad m => Module -> m ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | isHomeModule dflags md = True+ | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = unitIsTrusted $ unsafeLookupUnitId pkgstate pkg+ pkgstate = unitState dflags++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: GHC.GhcMonad m => String -> m Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d))+ (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()+browseModule bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: GhciMonad m => String -> m ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: GhciMonad m => ModuleName -> m ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: GhciMonad m => String -> m ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: GhciMonad m => InteractiveImport -> m ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GhciMonad m => m a -> m a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `MC.onException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GhciMonad m => m ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: GhciMonad m+ => [InteractiveImport] -> m [InteractiveImport]+getImplicitPreludeImports iidecls = do+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Clash.Prelude"++sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: GhciMonad m => String -> m ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :set prompt-cont <string>"+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest++ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ Right ("local-config", rest) ->+ setLocalConfigBehaviour $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: GhciMonad m => Bool -> m ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags) (llvmConfig dflags)++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: GhciMonad m => [String] -> m ()+setProg, setEditor, setStop :: GhciMonad m => String -> m ()+setLocalConfigBehaviour :: GhciMonad m => String -> m ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setLocalConfigBehaviour s+ | s == "source" =+ modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })+ | s == "ignore" =+ modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })+ | otherwise = throwGhcException+ (CmdLineError "syntax: :set local-config { source | ignore }")++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ case IntMap.lookup nm old_breaks of+ Nothing -> printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ Just loc -> do+ let new_breaks = IntMap.insert nm+ loc { onBreakCmd = dropWhile isSpace rest }+ old_breaks+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: GhciMonad m => PromptFunction -> m ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: GhciMonad m => PromptFunction -> m ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: MonadIO m+ => (PromptFunction -> m ()) -> String -> String -> m ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: MonadIO m+ => (PromptFunction -> m ()) -> String -> m ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ -- Load any new plugins+ hsc_env0 <- GHC.getSession+ idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)+ GHC.setInteractiveDynFlags idflags2+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags++ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ must_reload <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ -- delete targets and all eventually defined breakpoints. (#1620)+ clearAllTargets+ when must_reload $ do+ let units = preloadUnits (unitState dflags2)+ liftIO $ linkPackages hsc_env units+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ unitState = unitState dflags2+ , unitDatabases = unitDatabases dflags2+ , packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ hsc_env' = hsc_env { hsc_dflags =+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks } }++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs hsc_env'++ return ()+++unsetOptions :: GhciMonad m => String -> m ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: GhciMonad m => String -> m ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: forall m. GhciMonad m => String -> m ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ dflags <- getDynFlags+ hsc_env <- GHC.getSession++ let lookupCmd :: String -> Maybe (m ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> m () -> (Bool, String, m ())+ action name m = (True, name, m)++ hidden :: String -> m () -> (Bool, String, m ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ do+ msg <- liftIO $ showLinkerState (hsc_dynLinker hsc_env)+ dflags <- getDynFlags+ liftIO $ putLogMsg dflags NoReason SevDump noSrcSpan msg+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showUnits+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ , action "targets" $ showTargets+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: GHC.GhcMonad m => String -> m ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GhciMonad m => m ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHC.GhcMonad m => m ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)++showBindings :: GHC.GhcMonad m => m ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525+ -- See Note [Filter bindings]+ docs <- mapM makeDoc (reverse binds)+ -- reverse so the new ones come last+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)+ = pprTyThing showToHeader thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: GHC.GhcMonad m => TyThing -> m ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++{-+Note [Filter bindings]+~~~~~~~~~~~~~~~~~~~~~~++If we don't filter the bindings returned by the function GHC.getBindings,+then the :show bindings command will also show unwanted bound names,+internally generated by GHC, eg:+ $tcFoo :: GHC.Types.TyCon = _+ $trModule :: GHC.Unit.Module = _ .++The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this+ticket contains an analysis of the situation and suggests the solution+implemented above.++The same filter was also implemented to fix #11051 [3]. See the+Note [What to show to users] in GHC.Runtime.Eval++[1] https://gitlab.haskell.org/ghc/ghc/issues/12525+[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489+[3] https://gitlab.haskell.org/ghc/ghc/issues/11051+-}+++showBkptTable :: GhciMonad m => m ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHC.GhcMonad m => m ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ ptext (sLit "Stopped in")+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> text (moduleNameString mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showUnits :: GHC.GhcMonad m => m ()+showUnits = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHC.GhcMonad m => m ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHC.GhcMonad m => m ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHC.GhcMonad m => m ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags =+ defaultDynFlags (settings dflags) (llvmConfig dflags) `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++showTargets :: GHC.GhcMonad m => m ()+showTargets = mapM_ showTarget =<< GHC.getTargets+ where+ showTarget :: GHC.GhcMonad m => Target -> m ()+ showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)+ showTarget (Target (TargetModule m) _ _) =+ liftIO (putStrLn $ moduleNameString m)++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression, completeBreakpoint+ :: GhciMonad m => CompletionFunc m++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOptOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++-- TAB-completion for the :break command.+-- Build and return a list of breakpoint identifiers with a given prefix.+-- See Note [Tab-completion for :break]+completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000+ -- bid ~ breakpoint identifier = a name of a function that is+ -- eligible to set a breakpoint.+ let (mod_str, _, _) = splitIdent w+ bids_mod_breaks <- bidsFromModBreaks mod_str+ bids_inscopes <- bidsFromInscopes+ pure $ nub $ filter (isPrefixOf w) $ bids_mod_breaks ++ bids_inscopes+ where+ -- Extract all bids from ModBreaks for a given module name prefix+ bidsFromModBreaks :: GhciMonad m => String -> m [String]+ bidsFromModBreaks mod_pref = do+ imods <- interpretedHomeMods+ let pmods = filter ((isPrefixOf mod_pref) . showModule) imods+ nonquals <- case null mod_pref of+ -- If the prefix is empty, then for functions declared in a module+ -- in scope, don't qualify the function name.+ -- (eg: `main` instead of `Main.main`)+ True -> do+ imports <- GHC.getContext+ pure [ m | IIModule m <- imports]+ False -> return []+ bidss <- mapM (bidsByModule nonquals) pmods+ pure $ concat bidss++ -- Return a list of interpreted home modules+ interpretedHomeMods :: GhciMonad m => m [Module]+ interpretedHomeMods = do+ graph <- GHC.getModuleGraph+ let hmods = ms_mod <$> GHC.mgModSummaries graph+ filterM GHC.moduleIsInterpreted hmods++ -- Return all possible bids for a given Module+ bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]+ bidsByModule nonquals mod = do+ (_, _, decls) <- getModBreak mod+ let bids = nub $ declPath <$> elems decls+ pure $ case (moduleName mod) `elem` nonquals of+ True -> bids+ False -> (combineModIdent (showModule mod)) <$> bids++ -- Extract all bids from all top-level identifiers in scope.+ bidsFromInscopes :: GhciMonad m => m [String]+ bidsFromInscopes = do+ rdrs <- GHC.getRdrNamesInScope+ inscopess <- mapM createInscope $ (showSDocUnsafe . ppr) <$> rdrs+ imods <- interpretedHomeMods+ let topLevels = filter ((`elem` imods) . snd) $ concat inscopess+ bidss <- mapM (addNestedDecls) topLevels+ pure $ concat bidss++ -- Return a list of (bid,module) for a single top-level in-scope identifier+ createInscope :: GhciMonad m => String -> m [(String, Module)]+ createInscope str_rdr = do+ names <- GHC.parseName str_rdr+ pure $ zip (repeat str_rdr) $ GHC.nameModule <$> names++ -- For every top-level identifier in scope, add the bids of the nested+ -- declarations. See Note [ModBreaks.decls] in GHC.ByteCode.Types+ addNestedDecls :: GhciMonad m => (String, Module) -> m [String]+ addNestedDecls (ident, mod) = do+ (_, _, decls) <- getModBreak mod+ let (mod_str, topLvl, _) = splitIdent ident+ ident_decls = filter ((topLvl ==) . head) $ elems decls+ bids = nub $ declPath <$> ident_decls+ pure $ map (combineModIdent mod_str) bids++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: GHC.GhcMonad m => String -> m [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier+ :: Monad m+ => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames (unitState dflags)++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++{-+Note [Tab-completion for :break]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In tab-completion for the `:break` command, only those+identifiers should be shown, that are accepted in the+`:break` command. Hence these identifiers must be++- defined in an interpreted module+- listed in a `ModBreaks` value as a possible breakpoint.++The identifiers may be qualified or unqualified.++To get all possible top-level breakpoints for tab-completion+with the correct qualification do:++1. Build a list called `bids_mod_breaks` of identifier names eligible+for setting breakpoints: For every interpreted module with the+correct module prefix read all identifier names from the `decls` field+of the `ModBreaks` array.++2. Build a list called `bids_inscopess` of identifiers in scope:+Take all RdrNames in scope, and filter by interpreted modules.+Fore each of these top-level identifiers add from the `ModBreaks`+arrays the available identifiers of the nested functions.++3.) Combine both lists, filter by the given prefix, and remove duplicates.+-}++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()+sprintCmd = pprintClosureCommand False False+printCmd = pprintClosureCommand True False+forceCmd = pprintClosureCommand False True++stepCmd :: GhciMonad m => String -> m ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: GhciMonad m => String -> m ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690+ ":steplocal is not possible." +++ "\nCannot determine current top-level binding after " +++ "a break on error / exception.\nUse :stepmodule.")+ Just loc -> do+ md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Nothing) GHC.SingleStep++stepModuleCmd :: GhciMonad m => String -> m ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src _) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+ (realSrcSpanStart a `compare` realSrcSpanStart b)+ `thenCmp`+ (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: GhciMonad m => String -> m ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: GhciMonad m => String -> m ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()+doContinue pre step = do+ runResult <- resume pre step+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: GhciMonad m => String -> m ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: GhciMonad m => String -> m ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: GhciMonad m => [String] -> m ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: GhciMonad m => String -> m ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++enableCmd :: GhciMonad m => String -> m ()+enableCmd argLine = withSandboxOnly ":enable" $ do+ enaDisaSwitch True $ words argLine++disableCmd :: GhciMonad m => String -> m ()+disableCmd argLine = withSandboxOnly ":disable" $ do+ enaDisaSwitch False $ words argLine++enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()+enaDisaSwitch enaDisa [] =+ printForUser (text "The" <+> text strCmd <+>+ text "command requires at least one argument.")+ where+ strCmd = if enaDisa then ":enable" else ":disable"+enaDisaSwitch enaDisa ("*" : _) = enaDisaAllBreaks enaDisa+enaDisaSwitch enaDisa idents = do+ mapM_ (enaDisaOneBreak enaDisa) idents+ where+ enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()+ enaDisaOneBreak enaDisa strId = do+ sdoc_loc <- getBreakLoc enaDisa strId+ case sdoc_loc of+ Left sdoc -> printForUser sdoc+ Right loc -> enaDisaAssoc enaDisa (read strId, loc)++getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)+getBreakLoc enaDisa strId = do+ st <- getGHCiState+ case readMaybe strId >>= flip IntMap.lookup (breaks st) of+ Nothing -> return $ Left (text "Breakpoint" <+> text strId <+>+ text "not found")+ Just loc ->+ if breakEnabled loc == enaDisa+ then return $ Left+ (text "Breakpoint" <+> text strId <+>+ text "already in desired state")+ else return $ Right loc++enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()+enaDisaAssoc enaDisa (intId, loc) = do+ st <- getGHCiState+ newLoc <- turnBreakOnOff enaDisa loc+ let new_breaks = IntMap.insert intId newLoc (breaks st)+ setGHCiState $ st { breaks = new_breaks }++enaDisaAllBreaks :: GhciMonad m => Bool -> m()+enaDisaAllBreaks enaDisa = do+ st <- getGHCiState+ mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st++historyCmd :: GHC.GhcMonad m => String -> m ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: GhciMonad m => String -> m ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan, _) <- GHC.back num+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: GhciMonad m => String -> m ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :forward [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan, _) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: GhciMonad m => String -> m ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: GhciMonad m => [String] -> m ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ breakById arg1++breakByModule :: GhciMonad m => Module -> [String] -> m ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++-- Set a breakpoint for an identifier+-- See Note [Setting Breakpoints by Id]+breakById :: GhciMonad m => String -> m () -- #3000+breakById inp = do+ let (mod_str, top_level, fun_str) = splitIdent inp+ mod_top_lvl = combineModIdent mod_str top_level+ mb_mod <- catch (lookupModuleInscope mod_top_lvl)+ (\(_ :: SomeException) -> lookupModuleInGraph mod_str)+ -- If the top-level name is not in scope, `lookupModuleInscope` will+ -- throw an exception, then lookup the module name in the module graph.+ mb_err_msg <- validateBP mod_str fun_str mb_mod+ case mb_err_msg of+ Just err_msg -> printForUser $+ text "Cannot set breakpoint on" <+> quotes (text inp)+ <> text ":" <+> err_msg+ Nothing -> do+ -- No errors found, go and set the breakpoint+ mb_mod_info <- GHC.getModuleInfo $ fromJust mb_mod+ let modBreaks = case mb_mod_info of+ (Just mod_info) -> GHC.modInfoModBreaks mod_info+ Nothing -> emptyModBreaks+ findBreakAndSet (fromJust mb_mod) $ findBreakForBind fun_str modBreaks+ where+ -- Try to lookup the module for an identifier that is in scope.+ -- `parseName` throws an exception, if the identifier is not in scope+ lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)+ lookupModuleInscope mod_top_lvl = do+ names <- GHC.parseName mod_top_lvl+ pure $ Just $ head $ GHC.nameModule <$> names+ -- if GHC.parseName succeeds `names` is not empty!+ -- if it fails, the last line will not be evaluated.++ -- Lookup the Module of a module name in the module graph+ lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)+ lookupModuleInGraph mod_str = do+ graph <- GHC.getModuleGraph+ let hmods = ms_mod <$> GHC.mgModSummaries graph+ pure $ find ((== mod_str) . showModule) hmods++ -- Check validity of an identifier to set a breakpoint:+ -- 1. The module of the identifier must exist+ -- 2. the identifier must be in an interpreted module+ -- 3. the ModBreaks array for module `mod` must have an entry+ -- for the function+ validateBP :: GhciMonad m => String -> String -> Maybe Module+ -> m (Maybe SDoc)+ validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text+ (combineModIdent mod_str (Prelude.takeWhile (/= '.') fun_str)))+ <+> text "not in scope"+ validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"+ validateBP _ fun_str (Just modl) = do+ isInterpr <- GHC.moduleIsInterpreted modl+ (_, _, decls) <- getModBreak modl+ mb_err_msg <- case isInterpr of+ False -> pure $ Just $ text "Module" <+> quotes (ppr modl)+ <+> text "is not interpreted"+ True -> case fun_str `elem` (declPath <$> elems decls) of+ False -> pure $ Just $+ text "No breakpoint found for" <+> quotes (text fun_str)+ <+> "in module" <+> quotes (ppr modl)+ True -> pure Nothing+ pure mb_err_msg++breakSyntax :: a+breakSyntax = throwGhcException $ CmdLineError ("Syntax: :break [<mod>.]<func>[.<func>]\n"+ ++ " :break [<mod>] <line> [<column>]")++findBreakAndSet :: GhciMonad m+ => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ (breakArray, _, _) <- getModBreak md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ (breakAt breakArray) some+ where+ breakAt breakArray (tick, pan) = do+ setBreakFlag True breakArray tick+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan Nothing+ , breakTick = tick+ , onBreakCmd = ""+ , breakEnabled = True+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (it maybe a top-level or a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: String -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind str_name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),+ str_name == declPath decls,+ RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Nothing `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++{-+Note [Setting Breakpoints by Id]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To set a breakpoint first check whether a ModBreaks array contains a+breakpoint with the given function name:+In `:break M.foo` `M` may be a module name or a local alias of an import+statement. To lookup a breakpoint in the ModBreaks, the effective module+name is needed. Even if a module called `M` exists, `M` may still be+a local alias. To get the module name, parse the top-level identifier with+`GHC.parseName`. If this succeeds, extract the module name from the+returned value. If it fails, catch the exception and assume `M` is a real+module name.++The names of nested functions are stored in `ModBreaks.modBreaks_decls`.+-}++-----------------------------------------------------------------------------+-- :where++whereCmd :: GHC.GhcMonad m => String -> m ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: GhciMonad m => String -> m ()+listCmd "" = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan _) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd str = list2 (words str)++list2 :: GhciMonad m => [String] -> m ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ md <- lookupModuleName mn+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l _ ->+ do tickArray <- ASSERT( isExternalName name )+ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = GHC.mgLookupModule graph modl+ case this of+ Nothing -> panic "listModuleLine"+ Just summ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: GhciMonad m => Module -> m TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks, _) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GhciMonad m => m ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GhciMonad m => m ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnBreakOnOff False) $ breaks st+ setGHCiState $ st { breaks = IntMap.empty }++deleteBreak :: GhciMonad m => Int -> m ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ case IntMap.lookup identity oldLocations of+ Nothing -> printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ Just loc -> do+ _ <- (turnBreakOnOff False) loc+ let rest = IntMap.delete identity oldLocations+ setGHCiState $ st { breaks = rest }++turnBreakOnOff :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation+turnBreakOnOff onOff loc+ | onOff == breakEnabled loc = return loc+ | otherwise = do+ (arr, _, _) <- getModBreak (breakModule loc)+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr (breakTick loc) onOff+ return loc { breakEnabled = onOff }++getModBreak :: GHC.GhcMonad m+ => Module -> m (ForeignRef BreakArray, Array Int SrcSpan, Array Int [String])+getModBreak m = do+ mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ let decls = GHC.modBreaks_decls modBreaks+ return (arr, ticks, decls)++setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()+setBreakFlag toggle arr i = do+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler around the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: GhciMonad m => SomeException -> m Bool+handler exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: MonadIO m => SomeException -> m ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = mask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !dflags <- getDynFlags+ catch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)+ghciTry m = fmap Right m `catch` \e -> return $ Left e++tryBool :: ExceptionMonad m => m a -> m Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isMainUnitModule :: Module -> Bool+isMainUnitModule m = GHC.moduleUnit m == mainUnit++showModule :: Module -> String+showModule = moduleNameString . moduleName++-- Return a String with the declPath of the function of a breakpoint.+-- See Note [Field modBreaks_decls] in GHC.ByteCode.Types+declPath :: [String] -> String+declPath = intercalate "."++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ unless (isHomeModule dflags modl) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n++clearAllTargets :: GhciMonad m => m ()+clearAllTargets = discardActiveBreakPoints+ >> GHC.setTargets []+ >> GHC.load LoadAllTargets+ >> pure ()++-- Split up a string with an eventually qualified declaration name into 3 components+-- 1. module name+-- 2. top-level decl+-- 3. full-name of the eventually nested decl, but without module qualification+-- eg "foo" = ("", "foo", "foo")+-- "A.B.C.foo" = ("A.B.C", "foo", "foo")+-- "M.N.foo.bar" = ("M.N", "foo", "foo.bar")+splitIdent :: String -> (String, String, String)+splitIdent [] = ("", "", "")+splitIdent inp@(a : _)+ | (isUpper a) = case fixs of+ [] -> (inp, "", "")+ (i1 : [] ) -> (upto i1, from i1, from i1)+ (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1)+ | otherwise = case ixs of+ [] -> ("", inp, inp)+ (i1 : _) -> ("", upto i1, inp)+ where+ ixs = elemIndices '.' inp -- indices of '.' in whole input+ fixs = dropWhile isNextUc ixs -- indices of '.' in function names --+ isNextUc ix = isUpper $ safeInp !! (ix+1)+ safeInp = inp ++ " "+ upto i = take i inp+ from i = drop (i + 1) inp++-- Qualify an identifier name with a module name+-- combineModIdent "A" "foo" = "A.foo"+-- combineModIdent "" "foo" = "foo"+combineModIdent :: String -> String -> String+combineModIdent mod ident+ | null mod = ident+ | null ident = mod+ | otherwise = mod ++ "." ++ ident
+ src-bin-9.0/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing -Wno-compat-unqualified-imports #-}++-- | Get information on modules, expressions, and identifiers+module Clash.GHCi.UI.Info+ ( ModInfo(..)+ , SpanInfo(..)+ , spanInfoFromRealSrcSpan+ , collectInfo+ , findLoc+ , findNameUses+ , findType+ , getModInfo+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Catch as MC+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Data.Data+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Prelude hiding (mod,(<>))+import System.Directory++import qualified GHC.Core.Utils+import GHC.HsToCore+import GHC.Driver.Session (HasDynFlags(..))+import GHC.Data.FastString+import GHC+import GHC.Driver.Monad+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Utils.Outputable+import GHC.Types.SrcLoc+import GHC.Tc.Utils.Zonk+import GHC.Types.Var++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+ { modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ , modinfoSpans :: [SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ , modinfoInfo :: !ModuleInfo+ -- ^ Again, useful from GHC for accessing information+ -- (exports, instances, scope) from a module.+ , modinfoLastUpdate :: !UTCTime+ -- ^ The timestamp of the file used to generate this record.+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+ { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan+ -- ^ The span we associate information with+ , spaninfoType :: !(Maybe Type)+ -- ^ The 'Type' associated with the span+ , spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++instance Outputable SpanInfo where+ ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+ SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m [SrcSpan]+findNameUses infos span0 string =+ locToSpans <$> findLoc infos span0 string+ where+ locToSpans (modinfo,name',span') =+ stripSurrounding (span' : map toSrcSpan spans)+ where+ toSrcSpan s = RealSrcSpan (spaninfoSrcSpan s) Nothing+ spans = filter ((== Just name') . fmap getName . spaninfoVar)+ (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+ where+ isRedundant x = any (x `strictlyContains`) xs++ (RealSrcSpan s1 _) `strictlyContains` (RealSrcSpan s2 _)+ = s1 /= s2 && s1 `containsSpan` s2+ _ `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc m Name+findName infos span0 mi string =+ case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan {} -> tryExternalModuleResolution+ RealSrcSpan {} -> return (getName name)+ where+ tryExternalModuleResolution =+ case find (matchName $ mkFastString string)+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+ Nothing -> throwE "Couldn't resolve to any modules."+ Just imported -> resolveNameFromModule infos imported++ matchName :: FastString -> Name -> Bool+ matchName str name =+ str ==+ occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ maybe (throwE "No matching export in any local modules.") return $+ find (matchName name) (modInfoExports (modinfoInfo info))+ where+ matchName :: Name -> Name -> Bool+ matchName x y = occNameFS (getOccName x) ==+ occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+ reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> (,) info <$> lift (exprType TM_Inst string)+ Just ty -> return (info, ty)+ where+ -- | Try to resolve the type display from the given span.+ resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+ resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+ reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName ModInfo)+collectInfo ms loaded = do+ df <- getDynFlags+ liftIO (filterM cacheInvalid loaded) >>= \case+ [] -> return ms+ invalidated -> do+ liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))++ foldM (go df) ms invalidated+ where+ go df m name = do { info <- getModInfo name; return (M.insert name info m) }+ `MC.catch`+ (\(e :: SomeException) -> do+ liftIO $ putStrLn+ $ showSDocForUser df alwaysQualify+ $ "Error while getting type info from" <+>+ ppr name <> ":" <+> text (show e)+ return m)++ cacheInvalid name = case M.lookup name ms of+ Nothing -> return True+ Just mi -> do+ let fp = srcFilePath (modinfoSummary mi)+ last' = modinfoLastUpdate mi+ current <- getModificationTime fp+ exists <- doesFileExist fp+ if exists+ then return $ current /= last'+ else return True++-- | Get the source file path from a ModSummary.+-- If the .hs file is missing, and the .o file exists,+-- we return the .o file path.+srcFilePath :: ModSummary -> FilePath+srcFilePath modSum = fromMaybe obj_fp src_fp+ where+ src_fp = ml_hs_file ms_loc+ obj_fp = ml_obj_file ms_loc+ ms_loc = ms_location modSum++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ allTypes <- processAllTypeCheckedModule typechecked+ let i = tm_checked_module_info typechecked+ ts <- liftIO $ getModificationTime $ srcFilePath m+ return (ModInfo m allTypes i ts)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+ -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+ bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+ ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+ pts <- mapM getTypeLPat $ listifyAllSpans tcs+ return $ mapMaybe toSpanInfo+ $ sortBy cmpSpan+ $ catMaybes (bts ++ ets ++ pts)+ where+ tcs = tm_typechecked_source tcm++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+ getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})+ = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+ getTypeLHsBind _ = pure Nothing++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+ getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsExpr e = do+ hs_env <- getSession+ (_,mbe) <- liftIO $ deSugarExpr hs_env e+ return $ fmap (\expr -> (mid, getLoc e, GHC.Core.Utils.exprType expr)) mbe+ where+ mid :: Maybe Id+ mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i+ | otherwise = Nothing++ unwrapVar (XExpr (WrapExpr (HsWrap _ var))) = var+ unwrapVar e' = e'++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+ getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLPat (L spn pat) =+ pure (Just (getMaybeId pat,spn,hsPatType pat))+ where+ getMaybeId (VarPat _ (L _ vid)) = Just vid+ getMaybeId _ = Nothing++ -- | Get ALL source spans in the source.+ listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]+ listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+ where+ p (L spn _) = isGoodSrcSpan spn++ -- | Variant of @syb@'s @everything@ (which summarises all nodes+ -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+ everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+ everythingAllSpans k z f x+ | (False `mkQ` (const True :: NameSet -> Bool)) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++ cmpSpan (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++ -- | Pretty print the types into a 'SpanInfo'.+ toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+ toSpanInfo (n,RealSrcSpan spn _,typ)+ = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+ toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ src-bin-9.0/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,532 @@+{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor, DerivingVia #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+ GHCi(..), startGHCi,+ GHCiState(..), GhciMonad(..),+ GHCiOption(..), isOptionSet, setOption, unsetOption,+ Command(..), CommandResult(..), cmdSuccess,+ LocalConfigBehaviour(..),+ PromptFunction,+ BreakLocation(..),+ TickArray,+ getDynFlags,++ runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,+ ActionStats(..), runAndPrintStats, runWithStats, printStats,++ printForUserNeverQualify, printForUserModInfo,+ printForUser, printForUserPartWay, prettyLocations,++ compileGHCiExpr,+ initInterpBuffering,+ turnOffBuffering, turnOffBuffering_,+ flushInterpBuffers,+ mkEvalWrapper+ ) where++#include "HsVersions.h"++import Clash.GHCi.UI.Info (ModInfo)+import qualified GHC+import GHC.Driver.Monad hiding (liftIO)+import GHC.Utils.Outputable hiding (printForUser)+import qualified GHC.Utils.Outputable as Outputable+import GHC.Types.Name.Occurrence+import GHC.Driver.Session+import GHC.Data.FastString+import GHC.Driver.Types+import GHC.Types.SrcLoc+import GHC.Unit+import GHC.Types.Name.Reader as RdrName (mkOrig)+import GHC.Builtin.Names (gHC_GHCI_HELPERS)+import GHC.Runtime.Interpreter+import GHCi.RemoteTypes+import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import GHC.Hs.Utils+import GHC.Utils.Misc++import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad+import Prelude hiding ((<>))++import System.Console.Haskeline (CompletionFunc, InputT)+import Control.Monad.Catch as MC+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified Data.IntMap.Strict as IntMap+import qualified GHC.LanguageExtensions as LangExt++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+ {+ progname :: String,+ args :: [String],+ evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@+ prompt :: PromptFunction,+ prompt_cont :: PromptFunction,+ editor :: String,+ stop :: String,+ localConfig :: LocalConfigBehaviour,+ options :: [GHCiOption],+ line_number :: !Int, -- ^ input line+ break_ctr :: !Int,+ breaks :: !(IntMap.IntMap BreakLocation),+ tickarrays :: ModuleEnv TickArray,+ -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.+ ghci_commands :: [Command],+ -- ^ available ghci commands+ ghci_macros :: [Command],+ -- ^ user-defined macros+ last_command :: Maybe Command,+ -- ^ @:@ at the GHCi prompt repeats the last command, so we+ -- remember it here+ cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),+ -- ^ The command wrapper is run for each command or statement.+ -- The 'Bool' value denotes whether the command is successful and+ -- 'Nothing' means to exit GHCi.+ cmdqueue :: [String],++ remembered_ctx :: [InteractiveImport],+ -- ^ The imports that the user has asked for, via import+ -- declarations and :module commands. This list is+ -- persistent over :reloads (but any imports for modules+ -- that are not loaded are temporarily ignored). After a+ -- :load, all the home-package imports are stripped from+ -- this list.+ --+ -- See bugs #2049, #1873, #1360++ transient_ctx :: [InteractiveImport],+ -- ^ An import added automatically after a :load, usually of+ -- the most recently compiled module. May be empty if+ -- there are no modules loaded. This list is replaced by+ -- :load, :reload, and :add. In between it may be modified+ -- by :module.++ extra_imports :: [ImportDecl GhcPs],+ -- ^ These are "always-on" imports, added to the+ -- context regardless of what other imports we have.+ -- This is useful for adding imports that are required+ -- by setGHCiMonad. Be careful adding things here:+ -- you can create ambiguities if these imports overlap+ -- with other things in scope.+ --+ -- NB. although this is not currently used by GHCi itself,+ -- it was added to support other front-ends that are based+ -- on the GHCi code. Potentially we could also expose+ -- this functionality via GHCi commands.++ prelude_imports :: [ImportDecl GhcPs],+ -- ^ These imports are added to the context when+ -- -XImplicitPrelude is on and we don't have a *-module+ -- in the context. They can also be overridden by another+ -- import for the same module, e.g.+ -- "import Prelude hiding (map)"++ ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | A GHCi command+data Command+ = Command+ { cmdName :: String+ -- ^ Name of GHCi command (e.g. "exit")+ , cmdAction :: String -> InputT GHCi Bool+ -- ^ The 'Bool' value denotes whether to exit GHCi+ , cmdHidden :: Bool+ -- ^ Commands which are excluded from default completion+ -- and @:help@ summary. This is usually set for commands not+ -- useful for interactive use but rather for IDEs.+ , cmdCompletionFunc :: CompletionFunc GHCi+ -- ^ 'CompletionFunc' for arguments+ }++data CommandResult+ = CommandComplete+ { cmdInput :: String+ , cmdResult :: Either SomeException (Maybe Bool)+ , cmdStats :: ActionStats+ }+ | CommandIncomplete+ -- ^ Unterminated multiline command+ deriving Show++cmdSuccess :: MonadThrow m => CommandResult -> m (Maybe Bool)+cmdSuccess CommandComplete{ cmdResult = Left e } = throwM e+cmdSuccess CommandComplete{ cmdResult = Right r } = return r+cmdSuccess CommandIncomplete = return $ Just True++type PromptFunction = [String]+ -> Int+ -> GHCi SDoc++data GHCiOption+ = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about+ -- modules after load+ deriving Eq++-- | Treatment of ./.ghci files. For now we either load or+-- ignore. But later we could implement a "safe mode" where+-- only safe operations are performed.+--+data LocalConfigBehaviour+ = SourceLocalConfig+ | IgnoreLocalConfig+ deriving (Eq)++data BreakLocation+ = BreakLocation+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , breakEnabled:: !Bool+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick loc2++prettyLocations :: IntMap.IntMap BreakLocation -> SDoc+prettyLocations locs =+ case IntMap.null locs of+ True -> text "No active breakpoints."+ False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>+ if null (onBreakCmd loc)+ then Outputable.empty+ else doubleQuotes (text (onBreakCmd loc))+ where pprEnaDisa = case breakEnabled loc of+ True -> text "enabled"+ False -> text "disabled"++recordBreak+ :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldmap = breaks st+ oldActiveBreaks = IntMap.assocs oldmap+ -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = IntMap.insert oldCounter brkLoc oldmap+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }+ deriving (Functor)+ deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT (IORef GHCiState) Ghc)++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Applicative GHCi where+ pure a = GHCi $ \_ -> pure a+ (<*>) = ap++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class GhcMonad m => GhciMonad m where+ getGHCiState :: m GHCiState+ setGHCiState :: GHCiState -> m ()+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()+ reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> m a++instance GhciMonad GHCi where+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f+ reifyGHCi f = GHCi $ \r -> reifyGhc $ \s -> f (s, r)++instance GhciMonad (InputT GHCi) where+ getGHCiState = lift getGHCiState+ setGHCiState = lift . setGHCiState+ modifyGHCiState = lift . modifyGHCiState+ reifyGHCi = lift . reifyGHCi++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+ liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+ getDynFlags = getSessionDynFlags++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+ getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++isOptionSet :: GhciMonad m => GHCiOption -> m Bool+isOptionSet opt+ = do st <- getGHCiState+ return (opt `elem` options st)++setOption :: GhciMonad m => GHCiOption -> m ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GhciMonad m => GHCiOption -> m ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout neverQualify AllTheWay doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+ dflags <- getDynFlags+ mUnqual <- GHC.mkPrintUnqualifiedForModule info+ unqual <- maybe GHC.getPrintUnqual return mUnqual+ liftIO $ Outputable.printForUser dflags stdout unqual AllTheWay doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout unqual AllTheWay doc++printForUserPartWay :: GhcMonad m => SDoc -> m ()+printForUserPartWay doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout unqual Outputable.DefaultDepth doc++-- | Run a single Haskell expression+runStmt+ :: GhciMonad m+ => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)+runStmt stmt stmt_text step = do+ st <- getGHCiState+ GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do+ let opts = GHC.execOptions+ { GHC.execSourceFile = progname st+ , GHC.execLineNumber = line_number st+ , GHC.execSingleStep = step+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+ (EvalThis fhv) }+ Just <$> GHC.execStmt' stmt stmt_text opts++runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])+runDecls decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printException e;+ return Nothing) $ do+ r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+ return (Just r)++runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])+runDecls' decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $+ GHC.handleSourceError+ (\e -> do GHC.printException e;+ return Nothing)+ (Just <$> GHC.runParsedDecls decls)++resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++data ActionStats = ActionStats+ { actionAllocs :: Maybe Integer+ , actionElapsedTime :: Double+ } deriving Show++runAndPrintStats+ :: GhciMonad m+ => (a -> Maybe Integer)+ -> m a+ -> m (ActionStats, Either SomeException a)+runAndPrintStats getAllocs action = do+ result <- runWithStats getAllocs action+ case result of+ (stats, Right{}) -> do+ showTiming <- isOptionSet ShowTiming+ when showTiming $ do+ dflags <- getDynFlags+ liftIO $ printStats dflags stats+ _ -> return ()+ return result++runWithStats+ :: ExceptionMonad m+ => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)+runWithStats getAllocs action = do+ t0 <- liftIO getCurrentTime+ result <- MC.try action+ let allocs = either (const Nothing) getAllocs result+ t1 <- liftIO getCurrentTime+ let elapsedTime = realToFrac $ t1 `diffUTCTime` t0+ return (ActionStats allocs elapsedTime, result)++printStats :: DynFlags -> ActionStats -> IO ()+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}+ = do let secs_str = showFFloat (Just 2) secs+ putStrLn (showSDoc dflags (+ parens (text (secs_str "") <+> text "secs" <> comma <+>+ case mallocs of+ Nothing -> empty+ Just allocs ->+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . sep . reverse . show $ n+ where sep n'+ | n' `lengthAtMost` 3 = n'+ | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GhciMonad m => m ()+revertCAFs = do+ hsc_env <- GHC.getSession+ liftIO $ iservCmd hsc_env RtsRevertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) turnOffBuffering+ -- Have to turn off buffering again, because we just+ -- reverted stdout, stderr & stdin to their defaults.+++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+ let mkHelperExpr :: OccName -> Ghc ForeignHValue+ mkHelperExpr occ =+ GHC.compileParsedExprRemote+ $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ+ nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"+ flush <- mkHelperExpr $ mkVarOcc "flushAll"+ return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GhciMonad m => m ()+flushInterpBuffers = do+ st <- getGHCiState+ hsc_env <- GHC.getSession+ liftIO $ evalIO hsc_env (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GhciMonad m => m ()+turnOffBuffering = do+ st <- getGHCiState+ turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+ hsc_env <- getSession+ liftIO $ evalIO hsc_env fhv++mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+mkEvalWrapper progname args =+ runInternal $ GHC.compileParsedExprRemote+ $ evalWrapper `GHC.mkHsApp` nlHsString progname+ `GHC.mkHsApp` nlList (map nlHsString args)+ where+ nlHsString = nlHsLit . mkHsString+ evalWrapper =+ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")++-- | Run a 'GhcMonad' action to compile an expression for internal usage.+runInternal :: GhcMonad m => m a -> m a+runInternal =+ withTempSession mkTempSession+ where+ mkTempSession hsc_env = hsc_env+ { hsc_dflags = (hsc_dflags hsc_env) {+ -- Running GHCi's internal expression is incompatible with -XSafe.+ -- We temporarily disable any Safe Haskell settings while running+ -- GHCi internal expressions. (see #12509)+ safeHaskell = Sf_None+ }+ -- RebindableSyntax can wreak havoc with GHCi in several ways+ -- (see #13385 and #14342 for examples), so we temporarily+ -- disable it too.+ `xopt_unset` LangExt.RebindableSyntax+ -- We heavily depend on -fimplicit-import-qualified to compile expr+ -- with fully qualified names without imports.+ `gopt_set` Opt_ImplicitImportQualified+ }++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
+ src-bin-9.0/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -Wno-compat-unqualified-imports #-}+module Clash.GHCi.UI.Tags (+ createCTagsWithLineNumbersCmd,+ createCTagsWithRegExesCmd,+ createETagsFileCmd+) where++import GHC.Utils.Exception+import GHC+import Clash.GHCi.UI.Monad+import GHC.Utils.Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import GHC.Types.Name (nameOccName)+import GHC.Types.Name.Occurrence (pprOccName)+import GHC.Core.ConLike+import GHC.Utils.Monad++import Control.Monad+import Data.Function+import Data.List+import Data.Maybe+import Data.Ord+import GHC.Driver.Phases+import GHC.Utils.Panic+import Prelude+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+ createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd "" =+ ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+ ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd "" =+ ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+ ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+ createTagsFile kind file++-- ToDo:+-- - remove restriction that all modules must be interpreted+-- (problem: we don't know source locations for entities unless+-- we compiled the module.+--+-- - extract createTagsFile so it can be used from the command-line+-- (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+ graph <- GHC.getModuleGraph+ mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+ case either_res of+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+ Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+ is_interpreted <- GHC.moduleIsInterpreted m+ -- should we just skip these?+ when (not is_interpreted) $+ let mName = GHC.moduleNameString (GHC.moduleName m) in+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ mbModInfo <- GHC.getModuleInfo m+ case mbModInfo of+ Nothing -> return []+ Just mInfo -> do+ dflags <- getDynFlags+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+ let localNames = filter ((m==) . nameModule) names+ mbTyThings <- mapM GHC.lookupName localNames+ return $! [ tagInfo dflags unqual exported kind name realLoc+ | tyThing <- catMaybes mbTyThings+ , let name = getName tyThing+ , let exported = GHC.modInfoIsExportedName mInfo name+ , let kind = tyThing2TagKind tyThing+ , let loc = srcSpanStart (nameSrcSpan name)+ , RealSrcLoc realLoc _ <- [loc]+ ]++ where+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (ACoAxiom _) = 'x'+++data TagInfo = TagInfo+ { tagExported :: Bool -- is tag exported+ , tagKind :: Char -- tag kind+ , tagName :: String -- tag name+ , tagFile :: String -- file name+ , tagLine :: Int -- line number+ , tagCol :: Int -- column number+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset+ }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+ -> TagInfo+tagInfo dflags unqual exported kind name loc+ = TagInfo exported kind+ (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+ (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+ (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+ dfe <- doesFileExist file+ if dfe && isSourceFilename file+ then throwGhcException (CmdLineError (file ++ " is existing source file. " +++ "Please specify another file name to store tags data"))+ else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex expression being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+ let tags = unlines $ sort $ map showCTag tagInfos+ tryIO (writeTagsSafely file tags)++-- ctags style with the Ex expression being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+ let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+ tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+ let tagGroups = map processGroup tagInfoGroups+ tryIO (writeTagsSafely file $ concat tagGroups)++ where+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+ processGroup group@(tagInfo:_) =+ let tags = unlines $ map showETag group in+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+ let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+ mapM addTagSrcInfo groups++ where+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+ addTagSrcInfo group@(tagInfo:_) = do+ file <- readFile $tagFile tagInfo+ let sortedGroup = sortBy (comparing tagLine) group+ return $ perFile sortedGroup 1 0 $ lines file++ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+ | tagLine tag > cnt =+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+ | tagLine tag == cnt =+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+ perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++ tagKind ti : ( if tagExported ti then "" else "\tfile:" )++ where+ tagCmd =+ case tagSrcInfo ti of+ Nothing -> show $tagLine ti+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++ where+ escapeSlashes '/' r = '\\' : '/' : r+ escapeSlashes '\\' r = '\\' : '\\' : r+ escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+ tagSrcInfo = Just (srcLine,charPos) }+ = take (colNo - 1) srcLine ++ tag+ ++ "\x7f" ++ tag+ ++ "\x01" ++ show lineNo+ ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ src-bin-9.0/Clash/GHCi/Util.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++-- | Utilities for GHCi.+module Clash.GHCi.Util where++-- NOTE: Avoid importing GHC modules here, because the primary purpose+-- of this module is to not use UnboxedTuples in a module that imports+-- lots of other modules. See issue#13101 for more info.++import GHC.Exts+import GHC.Types++anyToPtr :: a -> IO (Ptr ())+anyToPtr x =+ IO (\s -> case anyToAddr# x s of+ (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
+ src-bin-9.0/Clash/Main.hs view
@@ -0,0 +1,1077 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain, defaultMainWithAction) where++-- The official GHC API+import qualified GHC+import GHC ( -- DynFlags(..), HscTarget(..),+ -- GhcMode(..), GhcLink(..),+ Ghc, GhcMonad(..),+ LoadHowMuch(..) )+import GHC.Driver.CmdLine++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import GHC.Iface.Load ( showIface )+import GHC.Driver.Main ( newHscEnv )+import GHC.Driver.Pipeline ( oneShot, compileFile )+import GHC.Driver.MakeFile ( doMkDependHS )+import GHC.Driver.Backpack ( doBackpack )+import GHC.Driver.Ways+#if defined(HAVE_INTERNAL_INTERPRETER)+import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+import GHC.Runtime.Loader ( loadFrontendPlugin )+import GHC.Driver.Plugins+#if defined(HAVE_INTERNAL_INTERPRETER)+import GHC.Runtime.Loader ( initializePlugins )+#endif+import GHC.Unit.Module ( ModuleName, mkModuleName )+++-- Various other random stuff that we need+import GHC.HandleEncoding+import GHC.Platform+import GHC.Platform.Host+import GHC.Settings.Config+import GHC.Settings.Constants+import GHC.Driver.Types+import GHC.Unit.State ( pprUnits, pprUnitsSimple )+import GHC.Driver.Phases+import GHC.Types.Basic ( failed )+import GHC.Driver.Session as DynFlags hiding (WarnReason(..))+import GHC.Utils.Error+import GHC.Data.FastString+import GHC.Utils.Outputable as Outputable+import GHC.SysTools.BaseDir+import GHC.Settings.IO+import GHC.Types.SrcLoc+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Types.Unique.Supply+import GHC.Utils.Monad ( liftIO )++-- Imports for --abi-hash+import GHC.Iface.Load ( loadUserInterface )+import GHC.Driver.Finder ( findImportedModule, cannotFindModule )+import GHC.Tc.Utils.Monad ( initIfaceCheck )+import GHC.Utils.Binary ( openBinMem, put_ )+import GHC.Iface.Recomp.Binary ( fingerprintBinMem )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except (throwE, runExceptT)+import Data.Char+import Data.List ( isPrefixOf, partition, intercalate, nub )+import qualified Data.Set as Set+import Data.Maybe+import Prelude++-- clash additions+import Paths_clash_ghc+import Clash.GHCi.UI (makeHDL)+import Control.Monad.Catch (catch)+import Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)++import qualified Clash.Backend+import Clash.Backend (AggressiveXOptBB)+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import Clash.Driver.Types+ (ClashOpts (..), defClashOpts)+import Clash.GHC.ClashFlags+import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Netlist.Types (PreserveCase)+import Clash.Util (clashLibVersion)+import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions)+import Clash.GHC.Util (handleClashException)++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++defaultMain :: [String] -> IO ()+defaultMain = defaultMainWithAction (return ())++defaultMainWithAction :: Ghc () -> [String] -> IO ()+defaultMainWithAction startAction = flip withArgs $ do+ initGCStatistics -- See Note [-Bsymbolic and hooks]+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ configureHandleEncoding+ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs++ -- let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+ -- mbMinusB | null minusB_args = Nothing+ -- | otherwise = Just (drop 2 (last minusB_args))++ let argv1 = map (mkGeneralLocated "on the commandline") argv0+ libDir <- ghcLibDir++ r <- newIORef defClashOpts+ (argv2, clashFlagWarnings) <- parseClashFlags r argv1++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2+ let flagWarnings = modeFlagWarnings ++ clashFlagWarnings++ -- If all we want to do is something like showing the version number+ -- then do it now, before we start a GHC session etc. This makes+ -- getting basic information much more resilient.++ -- In particular, if we wait until later before giving the version+ -- number then bootstrapping gets confused, as it tries to find out+ -- what version of GHC it's using before package.conf exists, so+ -- starting the session fails.+ case mode of+ Left preStartupMode ->+ do case preStartupMode of+ ShowSupportedExtensions -> showSupportedExtensions (Just libDir)+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ ShowOptions isInteractive -> showOptions isInteractive+ Right postStartupMode ->+ -- start our GHC session+ GHC.runGhc (Just libDir) $ do++ dflags <- GHC.getSessionDynFlags+ let dflagsExtra = setWantedLanguageExtensions dflags++ ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+ ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+ dflagsExtra1 = dflagsExtra+ { DynFlags.pluginModNames = nub $+ ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+ ghcTyLitKNPlugin :+ DynFlags.pluginModNames dflagsExtra+ }++ case postStartupMode of+ Left preLoadMode ->+ liftIO $ do+ case preLoadMode of+ ShowInfo -> showInfo dflagsExtra1+ ShowGhcUsage -> showGhcUsage dflagsExtra1+ ShowGhciUsage -> showGhciUsage dflagsExtra1+ PrintWithDynFlags f -> putStrLn (f dflagsExtra1)+ Right postLoadMode ->+ main' postLoadMode dflagsExtra1 argv3 flagWarnings startAction r++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]+ -> Ghc () -> IORef ClashOpts+ -> Ghc ()+main' postLoadMode dflags0 args flagWarnings startAction clashOpts = do+ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget+ -- can be further adjusted on a module by module basis, using only+ -- the -fvia-C and -fasm flags. If the default HscTarget is not+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.+ let dflt_target = hscTarget dflags0+ (mode, lang, link)+ = case postLoadMode of+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)+ DoMake -> (CompManager, dflt_target, LinkBinary)+ DoBackpack -> (CompManager, dflt_target, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)+ DoVHDL -> (CompManager, HscNothing, NoLink)+ DoVerilog -> (CompManager, HscNothing, NoLink)+ DoSystemVerilog -> (CompManager, HscNothing, NoLink)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ verbosity = case postLoadMode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overridden from the command-line+ -- XXX: this should really be in the interactive DynFlags, but+ -- we don't set that until later in interactiveUI+ -- We also set -fignore-optim-changes and -fignore-hpc-changes,+ -- which are program-level options. Again, this doesn't really+ -- feel like the right place to handle this, but we don't have+ -- a great story for the moment.+ dflags2 | DoInteractive <- postLoadMode = def_ghci_flags+ | DoEval _ <- postLoadMode = def_ghci_flags+ | otherwise = dflags1+ where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified+ `gopt_set` Opt_IgnoreOptimChanges+ `gopt_set` Opt_IgnoreHpcChanges++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags3, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags dflags2 args++ let dflags4 = case lang of+ HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->+ let platform = targetPlatform dflags3+ dflags3a = dflags3 { ways = hostFullWays }+ dflags3b = foldl gopt_set dflags3a+ $ concatMap (wayGeneralFlags platform)+ hostFullWays+ dflags3c = foldl gopt_unset dflags3b+ $ concatMap (wayUnsetGeneralFlags platform)+ hostFullWays+ in dflags3c+ _ ->+ dflags3++ GHC.prettyPrintGhcErrors dflags4 $ do++ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ handleFlagWarnings dflags4 flagWarnings'++ liftIO $ showBanner postLoadMode dflags4++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right+ -- away. Note the asymmetry of FilePath.normalise:+ -- Linux: p/q -> p/q; p\q -> p\q+ -- Windows: p/q -> p\q; p\q -> p\q+ -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs+ -- to -foo.hs. We have to re-prepend the current directory.+ normalise_hyp fp+ | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp+ | otherwise = nfp+ where+#if defined(mingw32_HOST_OS)+ strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp+#else+ strt_dot_sl = "./" `isPrefixOf` fp+#endif+ cur_dir = '.' : [pathSeparator]+ nfp = normalise fp+ normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ dflags5 = dflags4 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags4 }++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ ---------------- Display configuration -----------+ case verbosity dflags6 of+ v | v == 4 -> liftIO $ dumpUnitsSimple dflags6+ | v >= 5 -> liftIO $ dumpUnits dflags6+ | otherwise -> return ()++ liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)+ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags6 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ clashOpts' <- liftIO (readIORef clashOpts)+ let clash fun = catch (fun startAction clashOpts srcs) (handleClashException dflags6 clashOpts')+ case postLoadMode of+ ShowInterface f -> liftIO $ doShowIface dflags6 f+ DoMake -> doMake srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> liftIO (oneShot hsc_env p srcs)+ DoInteractive -> ghciUI clashOpts hsc_env dflags6 srcs Nothing+ DoEval exprs -> ghciUI clashOpts hsc_env dflags6 srcs $ Just $+ reverse exprs+ DoAbiHash -> abiHash (map fst srcs)+ ShowPackages -> liftIO $ showUnits dflags6+ DoFrontend f -> doFrontend f srcs+ DoBackpack -> doBackpack (map fst srcs)+ DoVHDL -> clash makeVHDL+ DoVerilog -> clash makeVerilog+ DoSystemVerilog -> clash makeSystemVerilog++ liftIO $ dumpFinalStats dflags6++ghciUI :: IORef ClashOpts -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+#if !defined(HAVE_INTERNAL_INTERPRETER)+ghciUI _ _ _ _ _ =+ throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI clashOpts hsc_env dflags0 srcs maybe_expr = do+ dflags1 <- liftIO (initializePlugins hsc_env dflags0)+ _ <- GHC.setSessionDynFlags dflags1+ interactiveUI (defaultGhciSettings clashOpts) srcs maybe_expr+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+ -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+ | "none" <- suff = partition_args args srcs objs+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)+ | otherwise = partition_args rest (these_srcs ++ srcs) objs+ where phase = startPhase suff+ (slurp,rest) = break (== "-x") args+ these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+ | otherwise = partition_args args srcs (arg:objs)++ {-+ We split out the object files (.o, .dll) and add them+ to ldInputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other+ haskellish extension),++ - module names (not forgetting hierarchical module names),++ - things beginning with '-' are flags that were not recognised by+ the flag parser, and we want them to generate errors later in+ checkOptions, so we class them as source files (#5921)++ - and finally we consider everything without an extension to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m+ || looksLikeModuleName m+ || "-" `isPrefixOf` m+ || not (hasExtension m)++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (not (Set.null (Set.filter wayRTSOnly (ways dflags)))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when ((Set.filter (not . wayRTSOnly) (ways dflags) /= hostFullWays)+ && isInterpretiveMode mode+ && not (gopt Opt_ExternalInterpreter dflags)) $+ do throwGhcException (UsageError+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")+ -- -ohi sanity check+ if (isJust (outputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then throwGhcException (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode mode+ then throwGhcException (UsageError "no input files")+ else do++ case mode of+ StopBefore HCc | hscTarget dflags /= HscC+ -> throwGhcException $ UsageError $+ "the option -C is only available with an unregisterised GHC"+ StopBefore (As False) | ghcLink dflags == NoLink+ -> throwGhcException $ UsageError $+ "the options -S and -fno-code are incompatible. Please omit -S"++ _ -> return ()++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags++-- Compiler output options++-- Called to verify that the output files point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278).+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir =+ throwGhcException (CmdLineError ("error: directory portion of " +++ show dir ++ " does not exist (used with " +++ show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode (ShowOptions False)++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+ = ShowGhcUsage -- ghc -?+ | ShowGhciUsage -- ghci -?+ | ShowInfo -- ghc --info+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+ $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+ = ShowInterface FilePath -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore Phase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoBackpack -- ghc --backpack foo.bkp+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoAbiHash -- ghc --abi-hash+ | ShowPackages -- ghc --show-packages+ | DoFrontend ModuleName -- ghc --frontend Plugin.Module+ | DoVHDL -- ghc --vhdl+ | DoVerilog -- ghc --verilog+ | DoSystemVerilog -- ghc --systemverilog++doMkDependHSMode, doMakeMode, doInteractiveMode,+ doAbiHashMode, showUnitsMode, doVHDLMode, doVerilogMode,+ doSystemVerilogMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+showUnitsMode = mkPostLoadMode ShowPackages+doVHDLMode = mkPostLoadMode DoVHDL+doVerilogMode = mkPostLoadMode DoVerilog+doSystemVerilogMode = mkPostLoadMode DoSystemVerilog++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++doFrontendMode :: String -> Mode+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))++doBackpackMode :: Mode+doBackpackMode = mkPostLoadMode DoBackpack++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore StopLn))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++isDoEvalMode :: Mode -> Bool+isDoEvalMode (Right (Right (DoEval _))) = True+isDoEvalMode _ = False++#if defined(HAVE_INTERNAL_INTERPRETER)+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode DoVHDL = True+needsInputsMode DoVerilog = True+needsInputsMode DoSystemVerilog = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode _ = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode DoVHDL = True+isCompManagerMode DoVerilog = True+isCompManagerMode DoSystemVerilog = True+isCompManagerMode _ = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Mode,+ [Located String],+ [Warn])+parseModeFlags args = do+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, [], [])+ mode = case mModeFlag of+ Nothing -> doMakeMode+ Just (m, _) -> m++ -- See Note [Handling errors when parsing commandline flags]+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+ map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2++ return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ defFlag "?" (PassFlag (setMode showGhcUsageMode))+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))+ , defFlag "V" (PassFlag (setMode showVersionMode))+ , defFlag "-version" (PassFlag (setMode showVersionMode))+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , defFlag "-info" (PassFlag (setMode showInfoMode))+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-show-packages" (PassFlag (setMode showUnitsMode))+ ] +++ [ defFlag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Project Git commit id",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "C compiler link flags",+ "ld flags"],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ] +++ ------- interfaces ----------------------------------------------------+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))++ ------- primary modes ------------------------------------------------+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))+ , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))+ , defFlag "-make" (PassFlag (setMode doMakeMode))+ , defFlag "-backpack" (PassFlag (setMode doBackpackMode))+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))+ , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))+ , defFlag "-verilog" (PassFlag (setMode doVerilogMode))+ , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))+ ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+ (mModeFlag, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- -c/--make are allowed together, and mean --make -no-link+ _ | isStopLnMode oldMode && isDoMakeMode newMode+ || isStopLnMode newMode && isDoMakeMode oldMode ->+ ((doMakeMode, "--make"), [])++ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, newFlag), [])++ -- If we have both -e and --interactive then -e always wins+ _ | isDoEvalMode oldMode &&+ isDoInteractiveMode newMode ->+ ((oldMode, oldFlag), [])+ | isDoEvalMode newMode &&+ isDoInteractiveMode oldMode ->+ ((newMode, newFlag), [])++ -- Otherwise, --help/--version/--numeric-version always win+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+ | isDominantFlag newMode -> ((newMode, newFlag), [])+ -- We need to accumulate eval flags like "-e foo -e bar"+ (Right (Right (DoEval esOld)),+ Right (Right (DoEval [eNew]))) ->+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),+ errs)+ -- Saying e.g. --interactive --interactive is OK+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++ -- --interactive and --show-options are used together+ (Right (Right DoInteractive), Left (ShowOptions _)) ->+ ((Left (ShowOptions True),+ "--interactive --show-options"), errs)+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->+ ((Left (ShowOptions True),+ "--show-options --interactive"), errs)+ -- Otherwise, complain+ _ -> let err = flagMismatchErr oldFlag newFlag+ in ((oldMode, oldFlag), err : errs)+ putCmdLineState (Just modeFlag', errs', flags')+ where isDominantFlag f = isShowGhcUsageMode f ||+ isShowGhciUsageMode f ||+ isShowVersionMode f ||+ isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+ (m, e, flags') <- getCmdLineState+ putCmdLineState (m, e, mkGeneralLocated loc s : flags')+ where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env StopLn srcs)+ else do++ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#if defined(HAVE_INTERNAL_INTERPRETER)+ -- Show the GHCi banner+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++-- TODO use GHC.Utils.Error once that is disentangled from all the other GhcMonad stuff?+showSupportedExtensions :: Maybe String -> IO ()+showSupportedExtensions m_top_dir = do+ res <- runExceptT $ do+ top_dir <- lift (tryFindTopDir m_top_dir) >>= \case+ Nothing -> throwE $ SettingsError_MissingData "Could not find the top directory, missing -B flag"+ Just dir -> pure dir+ initSettings top_dir+ targetPlatformMini <- case res of+ Right s -> pure $ platformMini $ sTargetPlatform s+ Left (SettingsError_MissingData msg) -> do+ hPutStrLn stderr $ "WARNING: " ++ show msg+ hPutStrLn stderr $ "cannot know target platform so guessing target == host (native compiler)."+ pure cHostPlatformMini+ Left (SettingsError_BadData msg) -> do+ hPutStrLn stderr msg+ exitWith $ ExitFailure 1+ mapM_ putStrLn $ supportedLanguagesAndExtensions targetPlatformMini++showVersion :: IO ()+showVersion = putStrLn $ concat [ "Clash, version "+ , Data.Version.showVersion Paths_clash_ghc.version+ , " (using clash-lib, version: "+ , Data.Version.showVersion clashLibVersion+ , ")"+ ]++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+ where+ availableOptions = concat [+ flagsForCompletion isInteractive,+ map ('-':) (getFlagNames mode_flags)+ ]+ getFlagNames opts = map flagName opts++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+ let usage_path = if ghci then ghciUsagePath dflags+ else ghcUsagePath dflags+ usage <- readFile usage_path+ dump usage+ where+ dump "" = return ()+ dump ('$':'$':s) = putStr progName >> dump s+ dump (c:s) = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+ when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ segments <- getFastStringTable+ hasZ <- getFastStringZEncCounter+ let buckets = concat segments+ bucketsPerSegment = map length segments+ entriesPerBucket = map length buckets+ entries = sum entriesPerBucket+ msg = text "FastString stats:" $$ nest 4 (vcat+ [ text "segments: " <+> int (length segments)+ , text "buckets: " <+> int (sum bucketsPerSegment)+ , text "entries: " <+> int entries+ , text "largest segment: " <+> int (maximum bucketsPerSegment)+ , text "smallest segment: " <+> int (minimum bucketsPerSegment)+ , text "longest bucket: " <+> int (maximum entriesPerBucket)+ , text "has z-encoding: " <+> (hasZ `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'++showUnits, dumpUnits, dumpUnitsSimple :: DynFlags -> IO ()+showUnits dflags = putStrLn (showSDoc dflags (pprUnits (unitState dflags)))+dumpUnits dflags = putMsg dflags (pprUnits (unitState dflags))+dumpUnitsSimple dflags = putMsg dflags (pprUnitsSimple (unitState dflags))++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+doFrontend modname srcs = do+ hsc_env <- getSession+ frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+ frontend frontend_plugin+ (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+ ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar. The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the ComponentId for a+package. The ComponentId must change when the visible ABI of+the package changes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (#5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+ -> Ghc ()+abiHash strs = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env++ liftIO $ do++ let find_it str = do+ let modname = mkModuleName str+ r <- findImportedModule hsc_env modname Nothing+ case r of+ Found _ m -> return m+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $+ cannotFindModule dflags modname r++ mods <- mapM find_it strs++ let get_iface modl = loadUserInterface NotBoot (text "abiHash") modl+ ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ put_ bh hiVersion+ -- package hashes change when the compiler version changes (for now)+ -- see #5328+ mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- HDL Generation++makeHDL'+ :: Clash.Backend.Backend backend+ => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)+ -> Ghc () -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' backend startAction r srcs = makeHDL backend startAction r $ fmap fst srcs++makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)++makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)++makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case match f (nubSort allNonDeprecatedFlags) of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))+ -- fixes #11789+ -- If the flag contains '=',+ -- this uses both the whole and the left side of '=' for comparing.+ match f allFlags+ | elem '=' f =+ let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags+ fName = takeWhile (/= '=') f+ in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+ | otherwise = fuzzyMatch f allFlags++{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initialize the flags in the RTS.++A byproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then+-- running it causes an error like this:+--+-- Loading temp shared object failed:+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics+--+-- Skipping the foreign call fixes this problem, and the outer GHCi+-- should have already made this call anyway.+#if defined(GHC_LOADED_INTO_GHCI)+initGCStatistics :: IO ()+initGCStatistics = return ()+#else+foreign import ccall safe "initGCStatistics"+ initGCStatistics :: IO ()+#endif
src-bin-common/Clash/GHCi/Common.hs view
@@ -1,3 +1,10 @@+{-|+ Copyright : (C) 2021, QBayLogic+ License : BSD2 (see the file LICENSE)+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-}@@ -6,7 +13,6 @@ ( checkImportDirs , checkMonoLocalBinds , checkMonoLocalBindsMod- , checkClashDynamic , getMainTopEntity ) where @@ -15,10 +21,17 @@ import Clash.Netlist.Types (TopEntityT(..)) -- The GHC interface-import qualified DynFlags+#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Data.EnumSet as GHC (member)+import GHC.Utils.Panic (GhcException (..), throwGhcException)+import qualified GHC+ (DynFlags, ModSummary (..), extensionFlags, moduleName, moduleNameString)+#else import qualified EnumSet as GHC (member)+import Panic (GhcException (..), throwGhcException) import qualified GHC (DynFlags, ModSummary (..), Module (..), extensionFlags, moduleNameString)+#endif import Clash.Core.Name (nameOcc) import Clash.Core.Var (varName) import Clash.Normalize.Util (collectCallGraphUniques, callGraph)@@ -30,10 +43,8 @@ import qualified Data.Text as Text import qualified Data.HashSet as HashSet import qualified GHC.LanguageExtensions as LangExt (Extension (..))-import Panic (GhcException (..), throwGhcException) import Control.Monad (forM_, unless, when)-import Distribution.System (OS(Windows), buildOS) import System.Directory (doesDirectoryExist) import System.IO (hPutStrLn, stderr) @@ -72,29 +83,36 @@ let topIdNm = Text.unpack (nameOcc (varName topId)) in topIdNm == nm || ('.':nm) `isSuffixOf` topIdNm --- | Checks whether MonoLocalBinds language extension is enabled or not in--- modules.+-- | Checks whether MonoLocalBinds and MonomorphismRestricton language extensions+-- are enabled or not in modules. checkMonoLocalBindsMod :: GHC.ModSummary -> IO ()-checkMonoLocalBindsMod x =- unless (active . GHC.ms_hspp_opts $ x) (hPutStrLn stderr $ msg x)+checkMonoLocalBindsMod x = do+ unless (active LangExt.MonoLocalBinds . GHC.ms_hspp_opts $ x)+ (hPutStrLn stderr $ msg LangExt.MonoLocalBinds x)+ unless (active LangExt.MonomorphismRestriction . GHC.ms_hspp_opts $ x)+ (hPutStrLn stderr $ msg LangExt.MonomorphismRestriction x) where- msg = messageWith . GHC.moduleNameString . GHC.moduleName . GHC.ms_mod+ msg ext = messageWith ext . GHC.moduleNameString . GHC.moduleName . GHC.ms_mod --- | Checks whether MonoLocalBinds language extension is enabled when generating--- the HDL directly e.g. in GHCi. modules.+-- | Checks whether MonoLocalBinds and MonomorphismRestriction language extensions+-- are enabled when generating the HDL directly e.g. in GHCi. modules. checkMonoLocalBinds :: GHC.DynFlags -> IO ()-checkMonoLocalBinds dflags =- unless (active dflags) (hPutStrLn stderr $ messageWith "")+checkMonoLocalBinds dflags = do+ unless (active LangExt.MonoLocalBinds dflags)+ (hPutStrLn stderr $ messageWith LangExt.MonoLocalBinds "")+ unless (active LangExt.MonomorphismRestriction dflags)+ (hPutStrLn stderr $ messageWith LangExt.MonomorphismRestriction "") -messageWith :: String -> String-messageWith srcModule+messageWith :: LangExt.Extension -> String -> String+messageWith ext srcModule | srcModule == [] = msgStem ++ "." | otherwise = msgStem ++ " in module: " ++ srcModule where- msgStem = "Warning: Extension MonoLocalBinds disabled. This might lead to unexpected logic duplication"+ msgStem = "Warning: Extension " <> show ext <>+ " is disabled. This might lead to unexpected logic duplication" -active :: GHC.DynFlags -> Bool-active = GHC.member LangExt.MonoLocalBinds . GHC.extensionFlags+active :: LangExt.Extension -> GHC.DynFlags -> Bool+active ext = GHC.member ext . GHC.extensionFlags checkImportDirs :: Foldable t => ClashOpts -> t FilePath -> IO () checkImportDirs opts idirs = when (opt_checkIDir opts) $@@ -102,14 +120,3 @@ doesDirectoryExist dir >>= \case False -> throwGhcException (CmdLineError $ "Missing directory: " ++ dir) _ -> return ()--checkClashDynamic :: GHC.DynFlags -> IO ()-checkClashDynamic dflags = do- let isStatic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of- Just "YES" -> False- _ -> True- when (isStatic && buildOS /= Windows)- (hPutStrLn stderr (unlines- ["WARNING: Clash is linked statically, which can lead to long startup times."- ,"See https://gitlab.haskell.org/ghc/ghc/issues/15524"- ]))
src-ghc/Clash/GHC/ClashFlags.hs view
@@ -14,9 +14,15 @@ ) where +#if MIN_VERSION_ghc(9,0,0)+import GHC.Driver.CmdLine+import GHC.Utils.Panic+import GHC.Types.SrcLoc+#else import CmdLineParser import Panic import SrcLoc+#endif import Control.Monad import Data.Char (isSpace)@@ -24,10 +30,12 @@ import Data.List (dropWhileEnd) import Data.List.Split (splitOn) import qualified Data.Set as Set+import qualified Data.Text as Text import Text.Read (readMaybe) import Clash.Driver.Types import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Clash.Netlist.Types (PreserveCase (ToLower)) parseClashFlags :: IORef ClashOpts -> [Located String] -> IO ([Located String]@@ -65,28 +73,33 @@ , defFlag "fclash-debug-transformations" $ SepArg (setDebugTransformations r) , defFlag "fclash-debug-transformations-from" $ OptIntSuffix (setDebugTransformationsFrom r) , defFlag "fclash-debug-transformations-limit" $ OptIntSuffix (setDebugTransformationsLimit r)+ , defFlag "fclash-debug-history" $ AnySuffix (liftEwM . (setRewriteHistoryFile r)) , defFlag "fclash-hdldir" $ SepArg (setHdlDir r) , defFlag "fclash-hdlsyn" $ SepArg (setHdlSyn r) , defFlag "fclash-nocache" $ NoArg (deprecated "nocache" "no-cache" setNoCache r) , defFlag "fclash-no-cache" $ NoArg (liftEwM (setNoCache r)) , defFlag "fclash-no-check-inaccessible-idirs" $ NoArg (liftEwM (setNoIDirCheck r))- , defFlag "fclash-noclean" $ NoArg (deprecated "noclean" "no-clean" setNoClean r)- , defFlag "fclash-no-clean" $ NoArg (liftEwM (setNoClean r))+ , defFlag "fclash-no-clean" $ NoArg (setNoClean r)+ , defFlag "fclash-clear" $ NoArg (liftEwM (setClear r)) , defFlag "fclash-no-prim-warn" $ NoArg (liftEwM (setNoPrimWarn r)) , defFlag "fclash-spec-limit" $ IntSuffix (liftEwM . setSpecLimit r) , defFlag "fclash-inline-limit" $ IntSuffix (liftEwM . setInlineLimit r) , defFlag "fclash-inline-function-limit" $ IntSuffix (liftEwM . setInlineFunctionLimit r) , defFlag "fclash-inline-constant-limit" $ IntSuffix (liftEwM . setInlineConstantLimit r)+ , defFlag "fclash-evaluator-fuel-limit" $ IntSuffix (liftEwM . setEvaluatorFuelLimit r) , defFlag "fclash-intwidth" $ IntSuffix (setIntWidth r) , defFlag "fclash-error-extra" $ NoArg (liftEwM (setErrorExtra r)) , defFlag "fclash-float-support" $ NoArg (liftEwM (setFloatSupport r)) , defFlag "fclash-component-prefix" $ SepArg (liftEwM . setComponentPrefix r) , defFlag "fclash-old-inline-strategy" $ NoArg (liftEwM (setOldInlineStrategy r)) , defFlag "fclash-no-escaped-identifiers" $ NoArg (liftEwM (setNoEscapedIds r))+ , defFlag "fclash-lower-case-basic-identifiers"$ NoArg (liftEwM (setLowerCaseBasicIds r)) , defFlag "fclash-compile-ultra" $ NoArg (liftEwM (setUltra r)) , defFlag "fclash-force-undefined" $ OptIntSuffix (setUndefined r) , defFlag "fclash-aggressive-x-optimization" $ NoArg (liftEwM (setAggressiveXOpt r))+ , defFlag "fclash-aggressive-x-optimization-blackboxes" $ NoArg (liftEwM (setAggressiveXOptBB r)) , defFlag "fclash-inline-workfree-limit" $ IntSuffix (liftEwM . setInlineWFLimit r)+ , defFlag "fclash-edalize" $ NoArg (liftEwM (setEdalize r)) ] -- | Print deprecated flag warning@@ -122,6 +135,12 @@ -> IO () setInlineConstantLimit r n = modifyIORef r (\c -> c {opt_inlineConstantLimit = toEnum n}) +setEvaluatorFuelLimit+ :: IORef ClashOpts+ -> Int+ -> IO ()+setEvaluatorFuelLimit r n = modifyIORef r (\c -> c {opt_evaluatorFuelLimit = toEnum n})+ setInlineWFLimit :: IORef ClashOpts -> Int@@ -165,9 +184,12 @@ setNoIDirCheck :: IORef ClashOpts -> IO () setNoIDirCheck r = modifyIORef r (\c -> c {opt_checkIDir = False}) -setNoClean :: IORef ClashOpts -> IO ()-setNoClean r = modifyIORef r (\c -> c {opt_cleanhdl = False})+setNoClean :: a -> EwM IO ()+setNoClean _ = addWarn "-fclash-no-clean has been removed" +setClear :: IORef ClashOpts -> IO ()+setClear r = modifyIORef r (\c -> c {opt_clear = True})+ setNoPrimWarn :: IORef ClashOpts -> IO () setNoPrimWarn r = modifyIORef r (\c -> c {opt_primWarn = False}) @@ -206,7 +228,8 @@ :: IORef ClashOpts -> String -> IO ()-setComponentPrefix r s = modifyIORef r (\c -> c {opt_componentPrefix = Just s})+setComponentPrefix r s =+ modifyIORef r (\c -> c {opt_componentPrefix = Just (Text.pack s)}) setOldInlineStrategy :: IORef ClashOpts -> IO () setOldInlineStrategy r = modifyIORef r (\c -> c {opt_newInlineStrat = False})@@ -214,6 +237,9 @@ setNoEscapedIds :: IORef ClashOpts -> IO () setNoEscapedIds r = modifyIORef r (\c -> c {opt_escapedIds = False}) +setLowerCaseBasicIds :: IORef ClashOpts -> IO ()+setLowerCaseBasicIds r = modifyIORef r (\c -> c {opt_lowerCaseBasicIds = ToLower})+ setUltra :: IORef ClashOpts -> IO () setUltra r = modifyIORef r (\c -> c {opt_ultra = True}) @@ -225,5 +251,20 @@ liftEwM (modifyIORef r (\c -> c {opt_forceUndefined = Just iM})) setAggressiveXOpt :: IORef ClashOpts -> IO ()-setAggressiveXOpt r = modifyIORef r (\c -> c { opt_aggressiveXOpt = True })+setAggressiveXOpt r = do+ modifyIORef r (\c -> c { opt_aggressiveXOpt = True })+ setAggressiveXOptBB r ++setAggressiveXOptBB :: IORef ClashOpts -> IO ()+setAggressiveXOptBB r = modifyIORef r (\c -> c { opt_aggressiveXOptBB = True })++setEdalize :: IORef ClashOpts -> IO ()+setEdalize r = modifyIORef r (\c -> c { opt_edalize = True })++setRewriteHistoryFile :: IORef ClashOpts -> String -> IO ()+setRewriteHistoryFile r arg = do+ let fileNm = case drop (length "-fclash-debug-history=") arg of+ [] -> "history.dat"+ str -> str+ modifyIORef r (\c -> c {opt_dbgRewriteHistoryFile = Just fileNm})
src-ghc/Clash/GHC/Evaluator.hs view
@@ -1,4438 +1,477 @@ {-|- Copyright : (C) 2013-2016, University of Twente,- 2016-2017, Myrtle Software Ltd,- 2017 , QBayLogic, Google Inc.- License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UnboxedTuples #-}--module Clash.GHC.Evaluator- ( primEvaluator- , isUndefinedPrimVal- ) where--import Control.Concurrent.Supply (Supply,freshId)-import Control.DeepSeq (force)-import Control.Exception (ArithException(..), Exception, tryJust, evaluate)-import Control.Monad.State.Strict (State, MonadState)-import qualified Control.Monad.State.Strict as State-import Control.Monad.Trans.Except (runExcept)-import Data.Bits-import Data.Char (chr,ord)-import qualified Data.Either as Either-import Data.Maybe (fromMaybe, mapMaybe)-import qualified Data.List as List-import qualified Data.Primitive.ByteArray as ByteArray-import Data.Proxy (Proxy)-import Data.Reflection (reifyNat)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Vector.Primitive as Vector-import GHC.Float-import GHC.Int-import GHC.Integer- (decodeDoubleInteger,encodeDoubleInteger,compareInteger,orInteger,andInteger,- xorInteger,complementInteger,absInteger,signumInteger)-import GHC.Integer.GMP.Internals- (Integer (..), BigNat (..))-import GHC.Natural-import GHC.Prim-import GHC.Real (Ratio (..))-import GHC.TypeLits (KnownNat)-import GHC.Types (IO (..))-import GHC.Word-import System.IO.Unsafe (unsafeDupablePerformIO)--import BasicTypes (Boxity (..))-import Name (getSrcSpan, nameOccName, occNameString)-import PrelNames- (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,- trueDataConKey, falseDataConKey)-import SrcLoc (wiredInSrcSpan)-import qualified TyCon-import TysWiredIn (tupleTyCon)-import Unique (getKey)--import Clash.Class.BitPack (pack,unpack)-import Clash.Core.DataCon (DataCon (..))-import Clash.Core.Evaluator-import Clash.Core.Evaluator.Types-import Clash.Core.Literal (Literal (..))-import Clash.Core.Name- (Name (..), NameSort (..), mkUnsafeSystemName)-import Clash.Core.Pretty (showPpr)-import Clash.Core.Term- (Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps)-import Clash.Core.TermInfo (piResultTys, applyTypeToArgs)-import Clash.Core.Type- (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,- splitFunForallTy, tyView)-import Clash.Core.TyCon- (TyConMap, TyConName, tyConDataCons)-import Clash.Core.TysPrim-import Clash.Core.Util- (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo,- undefinedTm)-import Clash.Core.Var (mkLocalId, mkTyVar)-import Clash.Debug-import Clash.GHC.GHC2Core (modNameM)-import Clash.Rewrite.Util (mkSelectorCase)-import Clash.Unique (lookupUniqMap)-import Clash.Util- (MonadUnique (..), clogBase, flogBase, curLoc)--import Clash.Promoted.Nat.Unsafe (unsafeSNat)-import qualified Clash.Sized.Internal.BitVector as BitVector-import qualified Clash.Sized.Internal.Signed as Signed-import qualified Clash.Sized.Internal.Unsigned as Unsigned-import Clash.Sized.Internal.BitVector(BitVector(..), Bit(..))-import Clash.Sized.Internal.Signed (Signed (..))-import Clash.Sized.Internal.Unsigned (Unsigned (..))-import Clash.XException (isX)--primEvaluator :: PrimEvaluator-primEvaluator = (reduceConstant, unwindPrim)----- | Evaluation of primitive operations.--- TODO This should really be in Clash.GHC.Evaluator -- the evaluator in--- clash-lib should NEVER refer to GHC primitives.-unwindPrim :: PrimUnwind-unwindPrim tcm p tys vs v [] m- | primName p `elem` [ "Clash.Sized.Internal.Index.fromInteger#"- , "GHC.CString.unpackCString#"- , "Clash.Transformations.removedArg"- , "GHC.Prim.MutableByteArray#"- , "Clash.Transformations.undefined"- ]- -- The above primitives are actually values, and not operations.- = unwind tcm m (PrimVal p tys (vs ++ [v]))- | primName p == "Clash.Sized.Internal.BitVector.fromInteger#"- = case (vs,v) of- ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->- unwind tcm m (PrimVal p tys [Lit (NaturalLiteral n), mask, Lit (IntegerLiteral (wrapUnsigned n i))])- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"- = case (vs,v) of- ([mask], integerLiteral -> Just i) ->- unwind tcm m (PrimVal p tys [mask, Lit (IntegerLiteral (wrapUnsigned 1 i))])- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | primName p == "Clash.Sized.Internal.Signed.fromInteger#"- = case (vs,v) of- ([naturalLiteral -> Just n],integerLiteral -> Just i) ->- unwind tcm m (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapSigned n i))])- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"- = case (vs,v) of- ([naturalLiteral -> Just n],integerLiteral -> Just i) ->- unwind tcm m (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapUnsigned n i))])- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | isUndefinedPrimVal v- = let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v])- in Just $ flip setTerm m $ undefinedTm $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- | otherwise- = mPrimStep m tcm (forcePrims m) p tys (vs ++ [v]) m--unwindPrim tcm p tys vs v [e] m0- -- Primitives are usually considered undefined when one of their arguments is- -- (unless they're unused). _Some_ primitives can still yield a result even- -- though one of their arguments is undefined. It turns out that all primitives- -- exhibiting this property happen to be "lazy" in their last argument. Thus,- -- all the cases can be covered by a match on [e] and their names:- | primName p `elem` [ "Clash.Sized.Vector.lazyV"- , "Clash.Sized.Vector.replicate"- , "Clash.Sized.Vector.replace_int"- , "GHC.Classes.&&"- , "GHC.Classes.||"- ]- = if isUndefinedPrimVal v then- let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ [Left e]- in Just $ flip setTerm m0 $ undefinedTm $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- else- let (m1,i) = newLetBinding tcm m0 e- in mPrimStep m0 tcm (forcePrims m0) p tys (vs ++ [v,Suspend (Var i)]) m1--unwindPrim tcm p tys vs (collectValueTicks -> (v, ts)) (e:es) m- | isUndefinedPrimVal v- = let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ map Left (e:es)- in Just $ flip setTerm m $ undefinedTm $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- | otherwise- = Just . setTerm e $ stackPush (PrimApply p tys (vs ++ [foldr TickValue v ts]) es) m---newtype PrimEvalMonad a = PEM (State Supply a)- deriving (Functor, Applicative, Monad, MonadState Supply)--instance MonadUnique PrimEvalMonad where- getUniqueM = PEM $ State.state (\s -> case freshId s of (!i,!s') -> (i,s'))--runPEM :: PrimEvalMonad a -> Supply -> (a, Supply)-runPEM (PEM m) = State.runState m--reduceConstant :: PrimStep-reduceConstant tcm isSubj pInfo tys args mach = case primName pInfo of--------------------- GHC.Prim.Char#------------------- "GHC.Prim.gtChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.geChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim.neChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.ltChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.leChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i <= j))- "GHC.Prim.ord#" | [i] <- charLiterals' args- -> reduce (integerToIntLiteral (toInteger $ ord i))--------------------- GHC.Prim.Int#------------------ "GHC.Prim.+#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i+j))- "GHC.Prim.-#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i-j))- "GHC.Prim.*#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i*j))-- "GHC.Prim.mulIntMayOflo#" | Just (i,j) <- intLiterals args- -> let !(I# a) = fromInteger i- !(I# b) = fromInteger j- c :: Int#- c = mulIntMayOflo# a b- in reduce (integerToIntLiteral (toInteger $ I# c))-- "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals args- -> reduce $ catchDivByZero (integerToIntLiteral (i `quot` j))- "GHC.Prim.remInt#" | Just (i,j) <- intLiterals args- -> reduce $ catchDivByZero (integerToIntLiteral (i `rem` j))- "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++- [Left $ catchDivByZero (integerToIntLiteral q)- ,Left $ catchDivByZero (integerToIntLiteral r)])- in reduce ret-- "GHC.Prim.andI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i .&. j))- "GHC.Prim.orI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i .|. j))- "GHC.Prim.xorI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `xor` j))- "GHC.Prim.notI#" | [i] <- intLiterals' args- -> reduce (integerToIntLiteral (complement i))-- "GHC.Prim.negateInt#"- | [Lit (IntLiteral i)] <- args- -> reduce (integerToIntLiteral (negate i))-- "GHC.Prim.addIntC#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(I# a) = fromInteger i- !(I# b) = fromInteger j- !(# d, c #) = addIntC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])- "GHC.Prim.subIntC#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(I# a) = fromInteger i- !(I# b) = fromInteger j- !(# d, c #) = subIntC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])-- "GHC.Prim.>#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.>=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.==#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim./=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.<#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.<=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Prim.chr#" | [i] <- intLiterals' args- -> reduce (charToCharLiteral (chr $ fromInteger i))-- "GHC.Prim.int2Word#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behavior-- "GHC.Prim.int2Float#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)- "GHC.Prim.int2Double#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)-- "GHC.Prim.word2Float#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)- "GHC.Prim.word2Double#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)-- "GHC.Prim.uncheckedIShiftL#"- | [ Lit (IntLiteral i)- , Lit (IntLiteral s)- ] <- args- -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))- "GHC.Prim.uncheckedIShiftRA#"- | [ Lit (IntLiteral i)- , Lit (IntLiteral s)- ] <- args- -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))- "GHC.Prim.uncheckedIShiftRL#" | Just (i,j) <- intLiterals args- -> let !(I# a) = fromInteger i- !(I# b) = fromInteger j- c :: Int#- c = uncheckedIShiftRL# a b- in reduce (integerToIntLiteral (toInteger $ I# c))---------------------- GHC.Prim.Word#------------------- "GHC.Prim.plusWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i+j))-- "GHC.Prim.subWordC#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# d, c #) = subWordC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])-- "GHC.Prim.plusWord2#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# h', l #) = plusWord2# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# h')- , Left (Literal . WordLiteral . toInteger $ W# l)])-- "GHC.Prim.minusWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i-j))- "GHC.Prim.timesWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i*j))-- "GHC.Prim.timesWord2#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# h', l #) = timesWord2# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# h')- , Left (Literal . WordLiteral . toInteger $ W# l)])-- "GHC.Prim.quotWord#" | Just (i,j) <- wordLiterals args- -> reduce $ catchDivByZero (integerToWordLiteral (i `quot` j))- "GHC.Prim.remWord#" | Just (i,j) <- wordLiterals args- -> reduce $ catchDivByZero (integerToWordLiteral (i `rem` j))- "GHC.Prim.quotRemWord#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++- [Left $ catchDivByZero (integerToWordLiteral q)- ,Left $ catchDivByZero (integerToWordLiteral r)])- in reduce ret- "GHC.Prim.quotRemWord2#" | [i,j,k'] <- wordLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(W# c) = fromInteger k'- !(# x, y #) = quotRemWord2# a b c- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# x)- , Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# y)])-- "GHC.Prim.and#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i .&. j))- "GHC.Prim.or#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i .|. j))- "GHC.Prim.xor#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i `xor` j))- "GHC.Prim.not#" | [i] <- wordLiterals' args- -> reduce (integerToWordLiteral (complement i))-- "GHC.Prim.uncheckedShiftL#"- | [ Lit (WordLiteral w)- , Lit (IntLiteral i)- ] <- args- -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))- "GHC.Prim.uncheckedShiftRL#"- | [ Lit (WordLiteral w)- , Lit (IntLiteral i)- ] <- args- -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))-- "GHC.Prim.word2Int#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behavior-- "GHC.Prim.gtWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.geWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.ltWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.leWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Prim.popCnt8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i- "GHC.Prim.popCnt16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.popCnt32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.popCnt64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.popCnt#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.clz8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i- "GHC.Prim.clz16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.clz32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.clz64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.clz#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.ctz8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)- "GHC.Prim.ctz16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)- "GHC.Prim.ctz32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)- "GHC.Prim.ctz64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)- "GHC.Prim.ctz#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.byteSwap16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.byteSwap32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.byteSwap64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.byteSwap#" | [i] <- wordLiterals' args -- assume 64bits- -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i--#if MIN_VERSION_base(4,14,0)- "GHC.Prim.bitReverse#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i -- assume 64bits- "GHC.Prim.bitReverse8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse8 . fromInteger $ i- "GHC.Prim.bitReverse16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse16 . fromInteger $ i- "GHC.Prim.bitReverse32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse32 . fromInteger $ i- "GHC.Prim.bitReverse64#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i-#endif----------------- Narrowing-------------- "GHC.Prim.narrow8Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow8Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow16Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow16Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow32Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow32Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow8Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow8Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b- "GHC.Prim.narrow16Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow16Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b- "GHC.Prim.narrow32Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow32Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b--------------- Double#------------ "GHC.Prim.>##" | Just r <- liftDDI (>##) args- -> reduce r- "GHC.Prim.>=##" | Just r <- liftDDI (>=##) args- -> reduce r- "GHC.Prim.==##" | Just r <- liftDDI (==##) args- -> reduce r- "GHC.Prim./=##" | Just r <- liftDDI (/=##) args- -> reduce r- "GHC.Prim.<##" | Just r <- liftDDI (<##) args- -> reduce r- "GHC.Prim.<=##" | Just r <- liftDDI (<=##) args- -> reduce r- "GHC.Prim.+##" | Just r <- liftDDD (+##) args- -> reduce r- "GHC.Prim.-##" | Just r <- liftDDD (-##) args- -> reduce r- "GHC.Prim.*##" | Just r <- liftDDD (*##) args- -> reduce r- "GHC.Prim./##" | Just r <- liftDDD (/##) args- -> reduce r-- "GHC.Prim.negateDouble#" | Just r <- liftDD negateDouble# args- -> reduce r- "GHC.Prim.fabsDouble#" | Just r <- liftDD fabsDouble# args- -> reduce r-- "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args- -> let !(D# a) = fromRational i- r = double2Int# a- in reduce . Literal . IntLiteral . toInteger $ I# r- "GHC.Prim.double2Float#"- | [Lit (DoubleLiteral d)] <- args- -> reduce (Literal (FloatLiteral (toRational (fromRational d :: Float))))--- "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args- -> reduce r- "GHC.Prim.logDouble#" | Just r <- liftDD logDouble# args- -> reduce r- "GHC.Prim.sqrtDouble#" | Just r <- liftDD sqrtDouble# args- -> reduce r- "GHC.Prim.sinDouble#" | Just r <- liftDD sinDouble# args- -> reduce r- "GHC.Prim.cosDouble#" | Just r <- liftDD cosDouble# args- -> reduce r- "GHC.Prim.tanDouble#" | Just r <- liftDD tanDouble# args- -> reduce r- "GHC.Prim.asinDouble#" | Just r <- liftDD asinDouble# args- -> reduce r- "GHC.Prim.acosDouble#" | Just r <- liftDD acosDouble# args- -> reduce r- "GHC.Prim.atanDouble#" | Just r <- liftDD atanDouble# args- -> reduce r- "GHC.Prim.sinhDouble#" | Just r <- liftDD sinhDouble# args- -> reduce r- "GHC.Prim.coshDouble#" | Just r <- liftDD coshDouble# args- -> reduce r- "GHC.Prim.tanhDouble#" | Just r <- liftDD tanhDouble# args- -> reduce r--#if MIN_VERSION_ghc(8,7,0)- "GHC.Prim.asinhDouble#" | Just r <- liftDD asinhDouble# args- -> reduce r- "GHC.Prim.acoshDouble#" | Just r <- liftDD acoshDouble# args- -> reduce r- "GHC.Prim.atanhDouble#" | Just r <- liftDD atanhDouble# args- -> reduce r-#endif-- "GHC.Prim.**##" | Just r <- liftDDD (**##) args- -> reduce r--- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)- "GHC.Prim.decodeDouble_2Int#" | [i] <- doubleLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i- !(# p, q, r, s #) = decodeDouble_2Int# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . WordLiteral . toInteger $ W# q)- , Left (Literal . WordLiteral . toInteger $ W# r)- , Left (Literal . IntLiteral . toInteger $ I# s)])--- decodeDouble_Int64# :: Double# -> (# Int64#, Int# #)- "GHC.Prim.decodeDouble_Int64#" | [i] <- doubleLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i- !(# p, q #) = decodeDouble_Int64# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I64# p)- , Left (Literal . IntLiteral . toInteger $ I# q)])------------- Float---------- "GHC.Prim.gtFloat#" | Just r <- liftFFI gtFloat# args- -> reduce r- "GHC.Prim.geFloat#" | Just r <- liftFFI geFloat# args- -> reduce r- "GHC.Prim.eqFloat#" | Just r <- liftFFI eqFloat# args- -> reduce r- "GHC.Prim.neFloat#" | Just r <- liftFFI neFloat# args- -> reduce r- "GHC.Prim.ltFloat#" | Just r <- liftFFI ltFloat# args- -> reduce r- "GHC.Prim.leFloat#" | Just r <- liftFFI leFloat# args- -> reduce r-- "GHC.Prim.plusFloat#" | Just r <- liftFFF plusFloat# args- -> reduce r- "GHC.Prim.minusFloat#" | Just r <- liftFFF minusFloat# args- -> reduce r- "GHC.Prim.timesFloat#" | Just r <- liftFFF timesFloat# args- -> reduce r- "GHC.Prim.divideFloat#" | Just r <- liftFFF divideFloat# args- -> reduce r-- "GHC.Prim.negateFloat#" | Just r <- liftFF negateFloat# args- -> reduce r- "GHC.Prim.fabsFloat#" | Just r <- liftFF fabsFloat# args- -> reduce r-- "GHC.Prim.float2Int#" | [i] <- floatLiterals' args- -> let !(F# a) = fromRational i- r = float2Int# a- in reduce . Literal . IntLiteral . toInteger $ I# r-- "GHC.Prim.expFloat#" | Just r <- liftFF expFloat# args- -> reduce r- "GHC.Prim.logFloat#" | Just r <- liftFF logFloat# args- -> reduce r- "GHC.Prim.sqrtFloat#" | Just r <- liftFF sqrtFloat# args- -> reduce r- "GHC.Prim.sinFloat#" | Just r <- liftFF sinFloat# args- -> reduce r- "GHC.Prim.cosFloat#" | Just r <- liftFF cosFloat# args- -> reduce r- "GHC.Prim.tanFloat#" | Just r <- liftFF tanFloat# args- -> reduce r- "GHC.Prim.asinFloat#" | Just r <- liftFF asinFloat# args- -> reduce r- "GHC.Prim.acosFloat#" | Just r <- liftFF acosFloat# args- -> reduce r- "GHC.Prim.atanFloat#" | Just r <- liftFF atanFloat# args- -> reduce r- "GHC.Prim.sinhFloat#" | Just r <- liftFF sinhFloat# args- -> reduce r- "GHC.Prim.coshFloat#" | Just r <- liftFF coshFloat# args- -> reduce r- "GHC.Prim.tanhFloat#" | Just r <- liftFF tanhFloat# args- -> reduce r- "GHC.Prim.powerFloat#" | Just r <- liftFFF powerFloat# args- -> reduce r--#if MIN_VERSION_base(4,12,0)- -- GHC.Float.asinh -- XXX: Very fragile- -- $w$casinh is the Double specialisation of asinh- -- $w$casinh1 is the Float specialisation of asinh- "GHC.Float.$w$casinh" | Just r <- liftDD go args- -> reduce r- where go f = case asinh (D# f) of- D# f' -> f'- "GHC.Float.$w$casinh1" | Just r <- liftFF go args- -> reduce r- where go f = case asinh (F# f) of- F# f' -> f'-#endif--#if MIN_VERSION_ghc(8,7,0)- "GHC.Prim.asinhFloat#" | Just r <- liftFF asinhFloat# args- -> reduce r- "GHC.Prim.acoshFloat#" | Just r <- liftFF acoshFloat# args- -> reduce r- "GHC.Prim.atanhFloat#" | Just r <- liftFF atanhFloat# args- -> reduce r-#endif-- "GHC.Prim.float2Double#" | [i] <- floatLiterals' args- -> let !(F# a) = fromRational i- r = float2Double# a- in reduce . Literal . DoubleLiteral . toRational $ D# r--- "GHC.Prim.newByteArray#"- | [iV,PrimVal rwTy _ _] <- args- , [i] <- intLiterals' [iV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- p = primCount mach- lit = Literal (ByteArrayLiteral (Vector.replicate (fromInteger i) 0))- mbaTy = mkFunTy intPrimTy (last tyArgs)- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left (mkApps (Prim (PrimInfo "GHC.Prim.MutableByteArray#" mbaTy WorkNever))- [Left (Literal . IntLiteral $ toInteger p)])- ])- in Just . setTerm newE $ primInsert p lit mach-- "GHC.Prim.setByteArray#"- | [PrimVal _mbaTy _ [baV]- ,offV,lenV,cV- ,PrimVal rwTy _ _- ] <- args- , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]- -> let Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =- primLookup (fromInteger ba) mach- !(I# off') = fromInteger off- !(I# len') = fromInteger len- !(I# c') = fromInteger c- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- svoid (setByteArray# mba off' len' c')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach-- "GHC.Prim.writeWordArray#"- | [PrimVal _mbaTy _ [baV]- ,iV,wV- ,PrimVal rwTy _ _- ] <- args- , [ba,i] <- intLiterals' [baV,iV]- , [w] <- wordLiterals' [wV]- -> let Just (Literal (ByteArrayLiteral (Vector.Vector off len ba1))) =- primLookup (fromInteger ba) mach- !(I# i') = fromInteger i- !(W# w') = fromIntegral w- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- svoid (writeWordArray# mba i' w')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral (Vector.Vector off len ba2))- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach-- "GHC.Prim.unsafeFreezeByteArray#"- | [PrimVal _mbaTy _ [baV]- ,PrimVal rwTy _ _- ] <- args- , [ba] <- intLiterals' [baV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- Just ba' = primLookup (fromInteger ba) mach- in reduce $ mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left ba'])-- "GHC.Prim.sizeofByteArray#"- | [Lit (ByteArrayLiteral ba)] <- args- -> reduce (Literal (IntLiteral (toInteger (Vector.length ba))))-- "GHC.Prim.indexWordArray#"- | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))),iV] <- args- , [i] <- intLiterals' [iV]- -> let !(I# i') = fromInteger i- !w = indexWordArray# ba i'- in reduce (Literal (WordLiteral (toInteger (W# w))))-- "GHC.Prim.getSizeofMutBigNat#"- | [PrimVal _mbaTy _ [baV]- ,PrimVal rwTy _ _- ] <- args- , [ba] <- intLiterals' [baV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- Just (Literal (ByteArrayLiteral ba')) = primLookup (fromInteger ba) mach- lit = Literal (IntLiteral (toInteger (Vector.length ba')))- in reduce $ mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left lit])-- "GHC.Prim.resizeMutableByteArray#"- | [PrimVal mbaTy _ [baV]- ,iV- ,PrimVal rwTy _ _- ] <- args- , [ba,i] <- intLiterals' [baV,iV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- p = primCount mach- Just (Literal (ByteArrayLiteral (Vector.Vector 0 _ ba1)))- = primLookup (fromInteger ba) mach- !(I# i') = fromInteger i- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of- (# s', mba' #) -> (# s', ByteArray.MutableByteArray mba' #))- ByteArray.unsafeFreezeByteArray mba'- ba3 = Literal (ByteArrayLiteral (Vector.Vector 0 (I# i') ba2))- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left (mkApps (Prim mbaTy)- [Left (Literal . IntLiteral $ toInteger p)])- ])- in Just . setTerm newE $ primInsert p ba3 mach-- "GHC.Prim.shrinkMutableByteArray#"- | [PrimVal _mbaTy _ [baV]- ,lenV- ,PrimVal rwTy _ _- ] <- args- , [ba,len] <- intLiterals' [baV,lenV]- -> let Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =- primLookup (fromInteger ba) mach- !(I# len') = fromInteger len- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- svoid (shrinkMutableByteArray# mba len')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach-- "GHC.Prim.copyByteArray#"- | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray src_ba)))- ,src_offV- ,PrimVal _mbaTy _ [dst_mbaV]- ,dst_offV, nV- ,PrimVal rwTy _ _- ] <- args- , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]- -> let Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen dst_ba))) =- primLookup (fromInteger dst_mba) mach- !(I# src_off') = fromInteger src_off- !(I# dst_off') = fromInteger dst_off- !(I# n') = fromInteger n- ba2 = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray dst_mba1 <- ByteArray.unsafeThawByteArray dst_ba- svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')- ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray dst_mba1)- ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach-- "GHC.Prim.readWordArray#"- | [PrimVal _mbaTy _ [baV]- ,offV- ,PrimVal rwTy _ _- ] <- args- , [ba,off] <- intLiterals' [baV,offV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- Just (Literal (ByteArrayLiteral (Vector.Vector _ _ ba1))) =- primLookup (fromInteger ba) mach- !(I# off') = fromInteger off- w = unsafeDupablePerformIO $ do- ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1- IO (\s -> case readWordArray# mba off' s of- (# s', w' #) -> (# s', W# w' #))- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left (Literal (WordLiteral (toInteger w)))- ])- in reduce newE---- decodeFloat_Int# :: Float# -> (#Int#, Int##)- "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(F# a) = fromRational i- !(# p, q #) = decodeFloat_Int# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . IntLiteral . toInteger $ I# q)])-- "GHC.Prim.tagToEnum#"- | [ConstTy (TyCon tcN)] <- tys- , [Lit (IntLiteral i)] <- args- -> let dc = do { tc <- lookupUniqMap tcN tcm- ; let dcs = tyConDataCons tc- ; List.find ((== (i+1)) . toInteger . dcTag) dcs- }- in (\e -> setTerm (Data e) mach) <$> dc--- "GHC.Classes.geInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))-- "GHC.Classes.&&"- | [ lArg , rArg ] <- args- -- evaluation of the arguments is deferred until the evaluation of the unwindPrim- -- to make `&&` lazy in both arguments- , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf tcm True (setTerm (valToTerm lArg) $ stackClear mach)- , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf tcm True (setTerm (valToTerm rArg) $ stackClear mach1)- -> case [ lArgWHNF, rArgWHNF ] of- [ Data lCon, Data rCon ] ->- Just $ mach2- { mStack = mStack mach- , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon && isTrueDC rCon)- }-- [ Data lCon, _ ]- | isTrueDC lCon -> reduce rArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty False)-- [ _, Data rCon ]- | isTrueDC rCon -> reduce lArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty False)-- _ -> Nothing-- "GHC.Classes.||"- | [ lArg , rArg ] <- args- -- evaluation of the arguments is deferred until the evaluation of the unwindPrim- -- to make `||` lazy in both arguments- , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf tcm True (setTerm (valToTerm lArg) $ stackClear mach)- , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf tcm True (setTerm (valToTerm rArg) $ stackClear mach1)- -> case [ lArgWHNF, rArgWHNF ] of- [ Data lCon, Data rCon ] ->- Just $ mach2- { mStack = mStack mach- , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon || isTrueDC rCon)- }-- [ Data lCon, _ ]- | isFalseDC lCon -> reduce rArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty True)-- [ _, Data rCon ]- | isFalseDC rCon -> reduce lArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty True)-- _ -> Nothing-- "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `div` j))-- -- modInt# :: Int# -> Int# -> Int#- "GHC.Classes.modInt#"- | [dividend, divisor] <- intLiterals' args- ->- if divisor == 0 then- let iTy = snd (splitFunForallTy ty) in- reduce (undefinedTm iTy)- else- reduce (Literal (IntLiteral (dividend `mod` divisor)))-- "GHC.Classes.not"- | [DC bCon _] <- args- -> reduce (boolToBoolLiteral tcm ty (nameOcc (dcName bCon) == "GHC.Types.False"))-- "GHC.Integer.Logarithms.integerLogBase#"- | Just (a,b) <- integerLiterals args- , Just c <- flogBase a b- -> (reduce . Literal . IntLiteral . toInteger) c-- "GHC.Integer.Type.smallInteger"- | [Lit (IntLiteral i)] <- args- -> reduce (Literal (IntegerLiteral i))-- "GHC.Integer.Type.integerToInt"- | [i] <- integerLiterals' args- -> reduce (integerToIntLiteral i)-- "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)- | [Lit (DoubleLiteral i)] <- args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i- !(# b, c #) = decodeDoubleInteger a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (integerToIntegerLiteral b)- , Left (integerToIntLiteral . toInteger $ I# c)])-- "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double#- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> let !(I# k') = fromInteger j- r = encodeDoubleInteger i k'- in reduce . Literal . DoubleLiteral . toRational $ D# r-- "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)- | [i, j] <- integerLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left $ catchDivByZero (integerToIntegerLiteral q)- , Left $ catchDivByZero (integerToIntegerLiteral r)])-- "GHC.Integer.Type.plusInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i+j))-- "GHC.Integer.Type.minusInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i-j))-- "GHC.Integer.Type.timesInteger" | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i*j))-- "GHC.Integer.Type.negateInteger"- | [i] <- integerLiterals' args- -> reduce (integerToIntegerLiteral (negate i))-- "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `div` j))-- "GHC.Integer.Type.modInteger" | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `mod` j))-- "GHC.Integer.Type.quotInteger" | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `quot` j))-- "GHC.Integer.Type.remInteger" | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `rem` j))-- "GHC.Integer.Type.divModInteger" | Just (i,j) <- integerLiterals args- -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty- (Just ubTupTc) = lookupUniqMap ubTupTcNm tcm- [ubTupDc] = tyConDataCons ubTupTc- (d,m) = divMod i j- in reduce $- mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi- , Right intTy, Right intTy- , Left $ catchDivByZero (Literal (IntegerLiteral d))- , Left $ catchDivByZero (Literal (IntegerLiteral m))- ]-- "GHC.Integer.Type.gtInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))-- "GHC.Integer.Type.geInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))-- "GHC.Integer.Type.eqInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))-- "GHC.Integer.Type.neqInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))-- "GHC.Integer.Type.ltInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))-- "GHC.Integer.Type.leInteger" | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))-- "GHC.Integer.Type.gtInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i > j))-- "GHC.Integer.Type.geInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i >= j))-- "GHC.Integer.Type.eqInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i == j))-- "GHC.Integer.Type.neqInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i /= j))-- "GHC.Integer.Type.ltInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i < j))-- "GHC.Integer.Type.leInteger#" | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Integer.Type.compareInteger" -- :: Integer -> Integer -> Ordering- | [i, j] <- integerLiterals' args- -> let -- Get the required result type (viewed as an applied type constructor name)- (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty- -- Find the type constructor from the name- (Just tupTc) = lookupUniqMap tupTcNm tcm- -- Get the data constructors of that type- -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'- [ltDc, eqDc, gtDc] = tyConDataCons tupTc- -- Do the actual compile-time evaluation- ordVal = compareInteger i j- in reduce $ case ordVal of- LT -> Data ltDc- EQ -> Data eqDc- GT -> Data gtDc-- "GHC.Integer.Type.shiftRInteger"- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))-- "GHC.Integer.Type.shiftLInteger"- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))-- "GHC.Integer.Type.wordToInteger"- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (IntegerLiteral w))-- "GHC.Integer.Type.integerToWord"- | [i] <- integerLiterals' args- -> reduce (integerToWordLiteral i)-- "GHC.Integer.Type.testBitInteger" -- :: Integer -> Int# -> Bool- | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args- -> reduce (boolToBoolLiteral tcm ty (testBit i (fromInteger j)))-- "GHC.Natural.NatS#"- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (NaturalLiteral w))-- "GHC.Natural.naturalToInteger"- | [i] <- naturalLiterals' args- -> reduce (Literal (IntegerLiteral (toInteger i)))-- "GHC.Natural.naturalFromInteger"- | [i] <- integerLiterals' args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy i id)-- -- GHC.shiftLNatural --- XXX: Fragile worker of GHC.shiflLNatural- "GHC.Natural.$wshiftLNatural"- | [nV,iV] <- args- , [n] <- naturalLiterals' [nV]- , [i] <- fromInteger <$> intLiterals' [iV]- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy n ((flip shiftL) i))-- "GHC.Natural.plusNatural"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j (+))-- "GHC.Natural.timesNatural"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j (*))-- "GHC.Natural.minusNatural"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->- case minusNaturalMaybe i' j' of- Nothing -> checkNaturalRange1 nTy (-1) id- Just n -> naturalToNaturalLiteral n))-- "GHC.Natural.wordToNatural#"- | [Lit (WordLiteral w)] <- args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy w id)-- "GHC.Natural.gcdNatural"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j gcd)-- -- GHC.Real.^ -- XXX: Very fragile- -- ^_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)- "GHC.Real.$wf" -- :: Integer -> Int# -> Integer- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral $ i ^ j)- "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#- | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args- -> reduce (integerToIntLiteral $ i ^ j)-- -- Type level ^ -- XXX: Very fragile- -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.- "Data.Singletons.TypeLits.Internal.$s^_f" -- ghc-8.4.4, singletons-2.4.1- | [i,j] <- naturalLiterals' args- -> reduce (Literal (NaturalLiteral (i ^ j)))- "Data.Singletons.TypeLits.Internal.$fSingI->^@#@$_f" -- ghc-8.6.5, singletons-2.5.1- | [i,j] <- naturalLiterals' args- -> reduce (Literal (NaturalLiteral (i ^ j)))- "Data.Singletons.TypeLits.Internal.%^_f" -- ghc-8.8.1, singletons-2.6- | [i,j] <- naturalLiterals' args- -> reduce (Literal (NaturalLiteral (i ^ j)))-- "GHC.TypeLits.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (integerToIntegerLiteral n)-- "GHC.TypeNats.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (Literal (NaturalLiteral n))-- "GHC.Types.C#"- | isSubj- , [Lit (CharLiteral c)] <- args- -> let (_,tyView -> TyConApp charTcNm []) = splitFunForallTy ty- (Just charTc) = lookupUniqMap charTcNm tcm- [charDc] = tyConDataCons charTc- in reduce (mkApps (Data charDc) [Left (Literal (CharLiteral c))])-- "GHC.Types.I#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I8#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I16#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I32#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])- "GHC.Int.I64#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-- "GHC.Types.W#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W8#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W16#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W32#"- | isSubj- , [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])- "GHC.Word.W64#"- | [Lit (WordLiteral c)] <- args- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])-- "GHC.Float.$w$sfromRat''" -- XXX: Very fragile- | [Lit (IntLiteral _minEx)- ,Lit (IntLiteral matDigs)- ,nV- ,dV] <- args- , [n,d] <- integerLiterals' [nV,dV]- -> case fromInteger matDigs of- matDigs'- | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))- | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))- _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"-- "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile- | [Lit (IntLiteral _minEx)- ,Lit (IntLiteral matDigs)- ,nV- ,dV] <- args- , [n,d] <- integerLiterals' [nV,dV]- -> case fromInteger matDigs of- matDigs'- | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))- | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))- _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"-- "GHC.Integer.Type.$wsignumInteger" -- XXX: Not super-fragile, but still..- | [i] <- integerLiterals' args- -> reduce (Literal (IntLiteral (signum i)))--- "GHC.Integer.Type.signumInteger"- | [i] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (signumInteger i)))-- "GHC.Integer.Type.absInteger"- | [i] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (absInteger i)))-- "GHC.Integer.Type.bitInteger"- | [i] <- intLiterals' args- -> reduce (Literal (IntegerLiteral (bit (fromInteger i))))-- "GHC.Integer.Type.complementInteger"- | [i] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (complementInteger i)))-- "GHC.Integer.Type.orInteger"- | [i, j] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (orInteger i j)))-- "GHC.Integer.Type.xorInteger"- | [i, j] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (xorInteger i j)))-- "GHC.Integer.Type.andInteger"- | [i, j] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (andInteger i j)))-- "GHC.Integer.Type.doubleFromInteger"- | [i] <- integerLiterals' args- -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))-- "GHC.Base.eqString"- | [PrimVal _ _ [Lit (StringLiteral s1)]- ,PrimVal _ _ [Lit (StringLiteral s2)]- ] <- args- -> reduce (boolToBoolLiteral tcm ty (s1 == s2))- | otherwise -> error (show args)--- "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64- | [DC _ [Left arg]] <- args- , mach2@Machine{mStack=[],mTerm=Literal (DoubleLiteral i)} <- whnf tcm True (setTerm arg $ stackClear mach)- -> let resTyInfo = extractTySizeInfo tcm ty tys- in Just $ mach2- { mStack = mStack mach- , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Double -> BitVector 64) $ fromRational i)- }-- "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32- | [DC _ [Left arg]] <- args- , mach2@Machine{mStack=[],mTerm=Literal (FloatLiteral i)} <- whnf tcm True (setTerm arg $ stackClear mach)- -> let resTyInfo = extractTySizeInfo tcm ty tys- in Just $ mach2- { mStack = mStack mach- , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Float -> BitVector 32) $ fromRational i)- }-- "Clash.Class.BitPack.unpackFloat#"- | [i] <- bitVectorLiterals' args- -> reduce (Literal (FloatLiteral (toRational $ (unpack :: BitVector 32 -> Float) (toBV i))))-- "Clash.Class.BitPack.unpackDouble#"- | [i] <- bitVectorLiterals' args- -> reduce (Literal (DoubleLiteral (toRational $ (unpack :: BitVector 64 -> Double) (toBV i))))-- -- expIndex#- -- :: KnownNat m- -- => Index m- -- -> SNat n- -- -> Index (n^m)- "Clash.Class.Exp.expIndex#"- | [b] <- indexLiterals' args- , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys- -> reduce (mkIndexLit ty (LitTy (NumTy (km^e))) (km^e) (b^e))-- -- expSigned#- -- :: KnownNat m- -- => Signed m- -- -> SNat n- -- -> Signed (n*m)- "Clash.Class.Exp.expSigned#"- | [b] <- signedLiterals' args- , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys- -> reduce (mkSignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))-- -- expUnsigned#- -- :: KnownNat m- -- => Unsigned m- -- -> SNat n- -- -> Unsigned m- "Clash.Class.Exp.expUnsigned#"- | [b] <- unsignedLiterals' args- , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys- -> reduce (mkUnsignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))-- "Clash.Promoted.Nat.powSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- -> let c = case a of- 2 -> 1 `shiftL` (fromInteger b)- _ -> a ^ b- (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c))- , Left (Literal (NaturalLiteral c))]-- "Clash.Promoted.Nat.flogBaseSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- flogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]-- "Clash.Promoted.Nat.clogBaseSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- clogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]-- "Clash.Promoted.Nat.logBaseSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- flogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]----------------- BitVector---------------- Constructor- "Clash.Sized.Internal.BitVector.BV"- | [Right _] <- map (runExcept . tyNatSize tcm) tys- , Just (m,i) <- integerLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo m i)-- "Clash.Sized.Internal.BitVector.Bit"- | Just (m,i) <- integerLiterals args- -> reduce (mkBitLit ty m i)---- Initialisation- "Clash.Sized.Internal.BitVector.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])- "Clash.Sized.Internal.BitVector.maxIndex#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])---- Construction- "Clash.Sized.Internal.BitVector.high"- -> reduce (mkBitLit ty 0 1)- "Clash.Sized.Internal.BitVector.low"- -> reduce (mkBitLit ty 0 0)-- "Clash.Sized.Internal.BitVector.undefined#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let resTyInfo = extractTySizeInfo tcm ty tys- mask = bit (fromInteger kn) - 1- in reduce (mkBitVectorLit' resTyInfo mask 0)---- Eq- "Clash.Sized.Internal.BitVector.eq##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.BitVector.neq##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.BitVector.lt##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.BitVector.ge##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.BitVector.gt##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.BitVector.le##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bits- "Clash.Sized.Internal.BitVector.and##"- | [i,j] <- bitLiterals args- -> let Bit msk val = BitVector.and## (toBit i) (toBit j)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.or##"- | [i,j] <- bitLiterals args- -> let Bit msk val = BitVector.or## (toBit i) (toBit j)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.xor##"- | [i,j] <- bitLiterals args- -> let Bit msk val = BitVector.xor## (toBit i) (toBit j)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))-- "Clash.Sized.Internal.BitVector.complement##"- | [i] <- bitLiterals args- -> let Bit msk val = BitVector.complement## (toBit i)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))---- Pack- "Clash.Sized.Internal.BitVector.pack#"- | [(msk,i)] <- bitLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo msk i)-- "Clash.Sized.Internal.BitVector.unpack#"- | [(msk,i)] <- bitVectorLiterals' args- -> reduce (mkBitLit ty msk i)---- Concatenation- "Clash.Sized.Internal.BitVector.++#" -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)- | Just (_,m) <- extractKnownNat tcm tys- , [(mski,i),(mskj,j)] <- bitVectorLiterals' args- -> let val = i `shiftL` fromInteger m .|. j- msk = mski `shiftL` fromInteger m .|. mskj- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo msk val)---- Reduction- "Clash.Sized.Internal.BitVector.reduceAnd#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy 0 val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceAnd# u)- "Clash.Sized.Internal.BitVector.reduceOr#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy 0 val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceOr# u)- "Clash.Sized.Internal.BitVector.reduceXor#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy 0 val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceXor# u)----- Indexing- "Clash.Sized.Internal.BitVector.index#" -- :: KnownNat n => BitVector n -> Int -> Bit- | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let resTy = getResultTy tcm ty tys- (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitLit resTy msk val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = (toInteger m, toInteger v)- where Bit m v = (BitVector.index# u i)- "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n- | Just (_, n) <- extractKnownNat tcm tys- , [ _- , PrimVal bvP _ [_, Lit (NaturalLiteral mskBv), Lit (IntegerLiteral bv)]- , valArgs -> Just [Literal (IntLiteral i)]- , PrimVal bP _ [Lit (WordLiteral mskB), Lit (IntegerLiteral b)]- ] <- args- , primName bvP == "Clash.Sized.Internal.BitVector.fromInteger#"- , primName bP == "Clash.Sized.Internal.BitVector.fromInteger##"- -> let resTyInfo = extractTySizeInfo tcm ty tys- (mskVal,val) = reifyNat n (op (BV (fromInteger mskBv) (fromInteger bv))- (fromInteger i)- (Bit (fromInteger mskB) (fromInteger b)))- in reduce (mkBitVectorLit' resTyInfo mskVal val)- where- op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> (Integer,Integer)- -- op bv i b _ = (BitVector.unsafeMask res, BitVector.unsafeToInteger res)- op bv i b _ = splitBV (BitVector.replaceBit# bv i b)- "Clash.Sized.Internal.BitVector.setSlice#"- -- :: SNat (m+1+i) -> BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)- | mTy : iTy : nTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- , Right iN <- runExcept (tyNatSize tcm iTy)- , Right n <- runExcept (tyNatSize tcm nTy)- , [i,j] <- bitVectorLiterals' args- -> let BV msk val = BitVector.setSlice# (unsafeSNat (m+1+iN)) (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j)- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.slice#"- -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)- | mTy : _ : nTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- , Right n <- runExcept (tyNatSize tcm nTy)- , [i] <- bitVectorLiterals' args- -> let BV msk val = BitVector.slice# (toBV i) (unsafeSNat m) (unsafeSNat n)- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)- | nTy : mTy : _ <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- , [(mski,i)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- bvTy : _ = tyArgs- valM = i `shiftR` fromInteger n- mskM = mski `shiftR` fromInteger n- valN = i .&. mask- mskN = mski .&. mask- mask = bit (fromInteger n) - 1- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (mkBitVectorLit bvTy mTy m mskM valM)- , Left (mkBitVectorLit bvTy nTy n mskN valN)])-- "Clash.Sized.Internal.BitVector.msb#" -- :: forall n. KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy (toInteger msk) (toInteger val))- where- op :: KnownNat n => BitVector n -> Proxy n -> (Word,Word)- op u _ = (unsafeMask# res, BitVector.unsafeToInteger# res)- where- res = BitVector.msb# u- "Clash.Sized.Internal.BitVector.lsb#" -- :: BitVector n -> Bit- | [i] <- bitVectorLiterals' args- -> let resTy = getResultTy tcm ty tys- Bit msk val = BitVector.lsb# (toBV i)- in reduce (mkBitLit resTy (toInteger msk) (toInteger val))----- Eq- -- eq#, neq# :: KnownNat n => BitVector n -> BitVector n -> Bool- "Clash.Sized.Internal.BitVector.eq#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty True)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.eq# ty tcm args)- -> reduce val-- "Clash.Sized.Internal.BitVector.neq#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty False)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.neq# ty tcm args)- -> reduce val---- Ord- -- lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool- "Clash.Sized.Internal.BitVector.lt#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty False)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.lt# ty tcm args)- -> reduce val- "Clash.Sized.Internal.BitVector.ge#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty True)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.ge# ty tcm args)- -> reduce val- "Clash.Sized.Internal.BitVector.gt#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty False)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.gt# ty tcm args)- -> reduce val- "Clash.Sized.Internal.BitVector.le#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty True)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.le# ty tcm args)- -> reduce val---- Bounded- "Clash.Sized.Internal.BitVector.minBound#"- | Just (nTy,len) <- extractKnownNat tcm tys- -> reduce (mkBitVectorLit ty nTy len 0 0)- "Clash.Sized.Internal.BitVector.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ mb) - 1- in reduce (mkBitVectorLit ty litTy mb 0 maxB)---- Num- "Clash.Sized.Internal.BitVector.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)- op u _ = splitBV (BitVector.negate# u)---- ExtendingNum- "Clash.Sized.Internal.BitVector.plus#" -- :: (KnownNat n, KnownNat m) => BitVector m -> BitVector n -> BitVector (Max m n + 1)- | [(0,i),(0,j)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i+j))-- "Clash.Sized.Internal.BitVector.minus#"- | [(0,i),(0,j)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 val)-- "Clash.Sized.Internal.BitVector.times#"- | [(0,i),(0,j)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i*j))---- Integral- "Clash.Sized.Internal.BitVector.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.BitVector.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.BitVector.toInteger#"- | Just (_, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (toBV i))- in reduce (integerToIntegerLiteral val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = BitVector.toInteger# u---- Bits- "Clash.Sized.Internal.BitVector.and#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.and#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.or#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.or#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.xor#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.xor#) ty tcm tys args)- -> reduce val-- "Clash.Sized.Internal.BitVector.complement#"- | [i] <- bitVectorLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)- op u _ = splitBV $ BitVector.complement# u-- "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)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.shiftL# u i)- "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)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.shiftR# u i)- "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)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.rotateL# u i)- "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)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.rotateR# u i)---- truncateB- "Clash.Sized.Internal.BitVector.truncateB#" -- forall a b . KnownNat a => BitVector (a + b) -> BitVector a- | aTy : _ <- tys- , Right ka <- runExcept (tyNatSize tcm aTy)- , [(mski,i)] <- bitVectorLiterals' args- -> let bitsKeep = (bit (fromInteger ka)) - 1- val = i .&. bitsKeep- msk = mski .&. bitsKeep- in reduce (mkBitVectorLit ty aTy ka msk val)------------- Index------------ BitPack- "Clash.Sized.Internal.Index.pack#"- | nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm nTy)- , [i] <- indexLiterals' args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo 0 i)- "Clash.Sized.Internal.Index.unpack#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [(0,i)] <- bitVectorLiterals' args- -> reduce (mkIndexLit ty nTy kn i)---- Eq- "Clash.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Index.lt#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Index.ge#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Index.gt#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Index.le#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.Index.maxBound#"- | Just (nTy,mb) <- extractKnownNat tcm tys- -> reduce (mkIndexLit ty nTy mb (mb - 1))---- Num- "Clash.Sized.Internal.Index.+#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> reduce (mkIndexLit ty nTy kn (i + j))- "Clash.Sized.Internal.Index.-#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> reduce (mkIndexLit ty nTy kn (i - j))- "Clash.Sized.Internal.Index.*#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> reduce (mkIndexLit ty nTy kn (i * j))---- ExtendingNum- "Clash.Sized.Internal.Index.plus#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkIndexLit' resTyInfo (i + j))- "Clash.Sized.Internal.Index.minus#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkIndexLit' resTyInfo (i - j))- "Clash.Sized.Internal.Index.times#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkIndexLit' resTyInfo (i * j))---- Integral- "Clash.Sized.Internal.Index.quot#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , Just (i,j) <- indexLiterals args- -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `quot` j))- "Clash.Sized.Internal.Index.rem#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , Just (i,j) <- indexLiterals args- -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `rem` j))- "Clash.Sized.Internal.Index.toInteger#"- | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args- , primName p == "Clash.Sized.Internal.Index.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Resize- "Clash.Sized.Internal.Index.resize#"- | Just (mTy,m) <- extractKnownNat tcm tys- , [i] <- indexLiterals' args- -> reduce (mkIndexLit ty mTy m i)-------------- Signed----------- "Clash.Sized.Internal.Signed.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])---- BitPack- "Clash.Sized.Internal.Signed.pack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkBitVectorLit ty nTy kn 0 val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.pack# s)- "Clash.Sized.Internal.Signed.unpack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [(0,i)] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op s _ = toInteger (Signed.unpack# s)---- Eq- "Clash.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Signed.lt#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Signed.ge#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Signed.gt#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.Signed.minBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let minB = negate (2 ^ (mb - 1))- in reduce (mkSignedLit ty litTy mb minB)- "Clash.Sized.Internal.Signed.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ (mb - 1)) - 1- in reduce (mkSignedLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.Signed.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.negate# s)- "Clash.Sized.Internal.Signed.abs#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.abs# s)---- ExtendingNum- "Clash.Sized.Internal.Signed.plus#"- | Just (i,j) <- signedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.Signed.minus#"- | Just (i,j) <- signedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))-- "Clash.Sized.Internal.Signed.times#"- | Just (i,j) <- signedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.Signed.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.div#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.mod#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.toInteger#"- | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args- , primName p == "Clash.Sized.Internal.Signed.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.Signed.and#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.Signed.or#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.Signed.xor#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.Signed.complement#"- | [i] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op u _ = toInteger (Signed.complement# u)-- "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)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.shiftL# u i)- "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)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.shiftR# u i)- "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)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.rotateL# u i)- "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)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.rotateR# u i)---- Resize- "Clash.Sized.Internal.Signed.resize#" -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m- | mTy : nTy : _ <- tys- , Right mInt <- runExcept (tyNatSize tcm mTy)- , Right nInt <- runExcept (tyNatSize tcm nTy)- , [i] <- signedLiterals' args- -> let val | nInt <= mInt = extended- | otherwise = truncated- extended = i- mask = 1 `shiftL` fromInteger (mInt - 1)- i' = i `mod` mask- truncated = if testBit i (fromInteger nInt - 1)- then (i' - mask)- else i'- in reduce (mkSignedLit ty mTy mInt val)- "Clash.Sized.Internal.Signed.truncateB#" -- KnownNat m => Signed (m + n) -> Signed m- | Just (mTy, km) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkSignedLit ty mTy km val)---- SaturatingNum--- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#--- It is just implemented in terms of other primitives.----------------- Unsigned------------- "Clash.Sized.Internal.Unsigned.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,ty') = splitFunForallTy ty- (TyConApp intTcNm _) = tyView ty'- (Just intTc) = lookupUniqMap intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])---- BitPack- "Clash.Sized.Internal.Unsigned.pack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- unsignedLiterals' args- -> reduce (mkBitVectorLit ty nTy kn 0 i)- "Clash.Sized.Internal.Unsigned.unpack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (toBV i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.unpack# u)---- Eq- "Clash.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Unsigned.lt#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Unsigned.ge#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Unsigned.gt#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Bounded- "Clash.Sized.Internal.Unsigned.minBound#"- | Just (nTy,len) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy len 0)- "Clash.Sized.Internal.Unsigned.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ mb) - 1- in reduce (mkUnsignedLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.Unsigned.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- unsignedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.negate# u)---- ExtendingNum- "Clash.Sized.Internal.Unsigned.plus#" -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)- | Just (i,j) <- unsignedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.Unsigned.minus#"- | [i,j] <- unsignedLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)-- "Clash.Sized.Internal.Unsigned.times#"- | Just (i,j) <- unsignedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.Unsigned.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Unsigned.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Unsigned.toInteger#"- | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args- , primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.Unsigned.and#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.Unsigned.or#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.Unsigned.xor#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.Unsigned.complement#"- | [i] <- unsignedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.complement# u)-- "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)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.shiftL# u i)- "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)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.shiftR# u i)- "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)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.rotateL# u i)- "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)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.rotateR# u i)---- Resize- "Clash.Sized.Internal.Unsigned.resize#" -- forall n m . KnownNat m => Unsigned n -> Unsigned m- | _ : mTy : _ <- tys- , Right km <- runExcept (tyNatSize tcm mTy)- , [i] <- unsignedLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkUnsignedLit ty mTy km val)---- Conversions- "Clash.Sized.Internal.Unsigned.unsignedToWord"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsignedToWord (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Sized.Internal.Unsigned.unsigned8toWord8"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsigned8toWord8 (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Sized.Internal.Unsigned.unsigned16toWord16"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsigned16toWord16 (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Sized.Internal.Unsigned.unsigned32toWord32"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsigned32toWord32 (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = lookupUniqMap wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"- | isSubj- , f : a : _ <- args- -> reduceWHNF (mkApps (valToTerm f) [Left (valToTerm a)])------------- RTree---------- "Clash.Sized.RTree.textract"- | isSubj- , [DC _ tArgs] <- args- -> reduceWHNF (Either.lefts tArgs !! 1)-- "Clash.Sized.RTree.tsplit"- | isSubj- , dTy : aTy : _ <- tys- , [DC _ tArgs] <- args- , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty- , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)- -> let (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- in reduce $- mkApps (Data tupDc)- [Right (mkTyConApp treeTcNm [dTy,aTy])- ,Right (mkTyConApp treeTcNm [dTy,aTy])- ,Left (Either.lefts tArgs !! 1)- ,Left (Either.lefts tArgs !! 2)- ]-- "Clash.Sized.RTree.tdfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : g : ts : _ <- args- , DC _ tArgs <- ts- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])- _ -> let k'ty = LitTy (NumTy (k'-1))- (tyArgs,_) = splitFunForallTy ty- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduceWHNF $- mkApps (valToTerm g)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Either.lefts tArgs !! 1)- ])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Either.lefts tArgs !! 2)- ])- ]-- "Clash.Sized.RTree.treplicate"- | isSubj- , let ty' = piResultTys tcm ty tys- , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'- , Right len <- runExcept (tyNatSize tcm lenTy)- -> let (Just treeTc) = lookupUniqMap treeTcNm tcm- [lrCon,brCon] = tyConDataCons treeTc- in reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))-------------- Vector----------- "Clash.Sized.Vector.length" -- :: KnownNat n => Vec n a -> Int- | isSubj- , [nTy, _] <- tys- , Right n <-runExcept (tyNatSize tcm nTy)- -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])-- "Clash.Sized.Vector.maxIndex"- | isSubj- , [nTy, _] <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = lookupUniqMap intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])---- Indexing- "Clash.Sized.Vector.index_int" -- :: KnownNat n => Vec n a -> Int- | nTy : aTy : _ <- tys- , _ : xs : i : _ <- args- , DC intDc [Left (Literal (IntLiteral i'))] <- i- -> if i' < 0- then Nothing- else case xs of- DC _ vArgs -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> Nothing- Right n' ->- if i' == 0- then reduceWHNF (Either.lefts vArgs !! 1)- else reduceWHNF $- mkApps (Prim pInfo)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Data intDc)- [Left (Literal (IntLiteral (i'-1)))])- ]- _ -> Nothing- _ -> Nothing- "Clash.Sized.Vector.head" -- :: Vec (n+1) a -> a- | isSubj- , [DC _ vArgs] <- args- -> reduceWHNF (Either.lefts vArgs !! 1)- "Clash.Sized.Vector.last" -- :: Vec (n+1) a -> a- | isSubj- , [DC _ vArgs] <- args- , (Right _ : Right aTy : Right nTy : _) <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> if n == 0- then reduceWHNF (Either.lefts vArgs !! 1)- else reduceWHNF- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)- ])--- - Sub-vectors- "Clash.Sized.Vector.tail" -- :: Vec (n+1) a -> Vec n a- | isSubj- , [DC _ vArgs] <- args- -> reduceWHNF (Either.lefts vArgs !! 2)- "Clash.Sized.Vector.init" -- :: Vec (n+1) a -> Vec n a- | isSubj- , [DC consCon vArgs] <- args- , (Right _ : Right aTy : Right nTy : _) <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> if n == 0- then reduceWHNF (Either.lefts vArgs !! 2)- else reduce $- mkVecCons consCon aTy n- (Either.lefts vArgs !! 1)- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)])- "Clash.Sized.Vector.select" -- :: (CmpNat (i+s) (s*n) ~ GT) => SNat f -> SNat s -> SNat n -> Vec (f + i) a -> Vec n a- | isSubj- , iTy : sTy : nTy : fTy : aTy : _ <- tys- , eq : f : s : n : xs : _ <- args- , Right n' <- runExcept (tyNatSize tcm nTy)- , Right f' <- runExcept (tyNatSize tcm fTy)- , Right i' <- runExcept (tyNatSize tcm iTy)- , Right s' <- runExcept (tyNatSize tcm sTy)- , DC _ vArgs <- xs- -> case n' of- 0 -> reduce (mkVecNil nilCon aTy)- _ -> case f' of- 0 -> let splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right sTy- ,Right (LitTy (NumTy (i'-s')))- ,Right aTy- ,Left (valToTerm s)- ,Left (valToTerm xs)- ]- fVecTy = mkTyConApp vecTcNm [sTy,aTy]- iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- fNm = mkUnsafeSystemName "fxs" 0- iNm = mkUnsafeSystemName "ixs" 1- fId = mkLocalId fVecTy fNm- iId = mkLocalId iVecTy iNm- tupPat = DataPat tupDc [] [fId,iId]- iAlt = (tupPat, (Var iId))- in reduce $- mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $- mkApps (Prim pInfo)- [Right (LitTy (NumTy (i'-s')))- ,Right sTy- ,Right (LitTy (NumTy (n'-1)))- ,Right (LitTy (NumTy 0))- ,Right aTy- ,Left (valToTerm eq)- ,Left (Literal (NaturalLiteral 0))- ,Left (valToTerm s)- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Case splitAtCall iVecTy [iAlt])- ]- _ -> let splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right fTy- ,Right iTy- ,Right aTy- ,Left (valToTerm f)- ,Left (valToTerm xs)- ]- fVecTy = mkTyConApp vecTcNm [fTy,aTy]- iVecTy = mkTyConApp vecTcNm [iTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- fNm = mkUnsafeSystemName "fxs" 0- iNm = mkUnsafeSystemName "ixs" 1- fId = mkLocalId fVecTy fNm- iId = mkLocalId iVecTy iNm- tupPat = DataPat tupDc [] [fId,iId]- iAlt = (tupPat, (Var iId))- in reduceWHNF $- mkApps (Prim pInfo)- [Right iTy- ,Right sTy- ,Right nTy- ,Right (LitTy (NumTy 0))- ,Right aTy- ,Left (valToTerm eq)- ,Left (Literal (NaturalLiteral 0))- ,Left (valToTerm s)- ,Left (valToTerm n)- ,Left (Case splitAtCall iVecTy [iAlt])- ]- where- (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- Just vecTc = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc--- - Splitting- "Clash.Sized.Vector.splitAt" -- :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)- | isSubj- , DC snatDc (Right mTy:_) <- head args- , Right m <- runExcept (tyNatSize tcm mTy)- -> let _:nTy:aTy:_ = tys- -- Get the tuple data-constructor- ty1 = piResultTys tcm ty tys- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty1- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- -- Get the vector data-constructors- TyConApp vecTcNm _ = tyView (head tyArgs)- Just vecTc = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- -- Recursive call to @splitAt@- splitAtRec v =- mkApps (Prim pInfo)- [Right (LitTy (NumTy (m-1)))- ,Right nTy- ,Right aTy- ,Left (mkApps (Data snatDc)- [ Right (LitTy (NumTy (m-1)))- , 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- lNm = mkUnsafeSystemName "l" 0- rNm = mkUnsafeSystemName "r" 1- lId = mkLocalId m1VecTy lNm- rId = mkLocalId nVecTy rNm- tupPat = DataPat tupDc [] [lId,rId]- lAlt = (tupPat, (Var lId))- rAlt = (tupPat, (Var rId))-- in case m of- -- (Nil,v)- 0 -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecNil nilCon aTy)- , Left (valToTerm (last args))- ]- -- (x:xs) <- v- m' | DC _ vArgs <- last args- -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))- -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)- (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))- , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])- ]- -- v doesn't reduce to a data-constructor- _ -> Nothing-- "Clash.Sized.Vector.unconcat" -- :: KnownNat n => SNamt m -> Vec (n * m) a -> Vec n (Vec m a)- | isSubj- , kn : snat : v : _ <- args- , nTy : mTy : aTy :_ <- tys- , Lit (NaturalLiteral n) <- kn- -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =- splitFunForallTy ty- Just vecTc = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- TyConApp snatTcNm _ = tyView (argTys !! 1)- n1mTy = mkTyConApp typeNatMul- [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]- ,mTy]- splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right mTy- ,Right n1mTy- ,Right aTy- ,Left (valToTerm snat)- ,Left (valToTerm v)- ]- mVecTy = mkTyConApp vecTcNm [mTy,aTy]- n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- asNm = mkUnsafeSystemName "as" 0- bsNm = mkUnsafeSystemName "bs" 1- asId = mkLocalId mVecTy asNm- bsId = mkLocalId n1mVecTy bsNm- tupPat = DataPat tupDc [] [asId,bsId]- asAlt = (tupPat, (Var asId))- bsAlt = (tupPat, (Var bsId))-- in case n of- 0 -> reduce (mkVecNil nilCon mVecTy)- _ -> reduce $- mkVecCons consCon mVecTy n- (Case splitAtCall mVecTy [asAlt])- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right mTy- ,Right aTy- ,Left (Literal (NaturalLiteral (n-1)))- ,Left (valToTerm snat)- ,Left (Case splitAtCall n1mVecTy [bsAlt])])--- Construction--- - initialisation- "Clash.Sized.Vector.replicate" -- :: SNat n -> a -> Vec n a- | isSubj- , let ty' = piResultTys tcm ty tys- , let (_,resTy) = splitFunForallTy ty'- , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy- , Right len <- runExcept (tyNatSize tcm lenTy)- -> let (Just vecTc) = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduce $- mkVec nilCon consCon argTy len- (replicate (fromInteger len) (valToTerm (last args)))--- - Concatenation- "Clash.Sized.Vector.++" -- :: Vec n a -> Vec m a -> Vec (n + m) a- | isSubj- , DC dc vArgs <- head args- , Right nTy : Right aTy : _ <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (valToTerm (last args))- n' | (_ : _ : mTy : _) <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- -> -- x : (xs ++ ys)- reduce $- mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Right mTy- ,Left (Either.lefts vArgs !! 2)- ,Left (valToTerm (last args))- ])- _ -> Nothing- "Clash.Sized.Vector.concat" -- :: Vec n (Vec m a) -> Vec (n * m) a- | isSubj- , (nTy : mTy : aTy : _) <- tys- , (xs : _) <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- _ | _ : h' : t : _ <- Either.lefts vArgs- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- -> reduceWHNF $- mkApps (vecAppendPrim vecTcNm)- [Right mTy- ,Right aTy- ,Right $ mkTyConApp typeNatMul- [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]- ,Left h'- ,Left $ mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n-1)))- , Right mTy- , Right aTy- , Left t- ]- ]- _ -> Nothing---- Modifying vectors- "Clash.Sized.Vector.replace_int" -- :: KnownNat n => Vec n a -> Int -> a -> Vec n a- | nTy : aTy : _ <- tys- , _ : xs : i : a : _ <- args- , DC intDc [Left (Literal (IntLiteral i'))] <- i- -> if i' < 0- then Nothing- else case xs of- DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> Nothing- Right n' ->- if i' == 0- then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))- else reduce $- mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Data intDc)- [Left (Literal (IntLiteral (i'-1)))])- ,Left (valToTerm a)- ])- _ -> Nothing- _ -> Nothing-- "Clash.Transformations.eqInt"- | [ DC _ [Left (Literal (IntLiteral i))]- , DC _ [Left (Literal (IntLiteral j))]- ] <- args- -> reduce (boolToBoolLiteral tcm ty (i == j))---- - specialized permutations- "Clash.Sized.Vector.reverse" -- :: Vec n a -> Vec n a- | isSubj- , nTy : aTy : _ <- tys- , [DC vecDc vArgs] <- args- -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> reduce (mkVecNil vecDc aTy)- Right n- | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , let (Just vecTc) = lookupUniqMap vecTcNm tcm- , let [nilCon,consCon] = tyConDataCons vecTc- -> reduceWHNF $- mkApps (vecAppendPrim vecTcNm)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Right (LitTy (NumTy 1))- ,Left (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)- ])- ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])- ]- _ -> Nothing- "Clash.Sized.Vector.transpose" -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)- | isSubj- , nTy : mTy : aTy : _ <- tys- , kn : xss : _ <- args- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , DC _ vArgs <- xss- , Right n <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- -> case m of- 0 -> let (Just vecTc) = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduce $- mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n- (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))- m' -> let (Just vecTc) = lookupUniqMap vecTcNm tcm- [_,consCon] = tyConDataCons vecTc- Just (consCoTy : _) = dataConInstArgTys consCon- [mTy,aTy,LitTy (NumTy (m'-1))]- in reduceWHNF $- mkApps (vecZipWithPrim vecTcNm)- [ Right aTy- , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])- , Right (mkTyConApp vecTcNm [mTy,aTy])- , Right nTy- , Left (mkApps (Data consCon)- [Right mTy- ,Right aTy- ,Right (LitTy (NumTy (m'-1)))- ,Left (primCo consCoTy)- ])- , Left (Either.lefts vArgs !! 1)- , Left (mkApps (Prim pInfo)- [ Right nTy- , Right (LitTy (NumTy (m'-1)))- , Right aTy- , Left (valToTerm kn)- , Left (Either.lefts vArgs !! 2)- ])- ]-- "Clash.Sized.Vector.rotateLeftS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a- | nTy : aTy : _ : _ <- tys- , kn : xs : d : _ <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- n' | DC snatDc [_,Left d'] <- d- , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf tcm isSubj (setTerm d' $ stackClear mach)- -> case (d2 `mod` n) of- 0 -> reduce (valToTerm xs)- d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- (Just vecTc) = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduceWHNF' mach2 $- mkApps (Prim pInfo)- [Right nTy- ,Right aTy- ,Right (LitTy (NumTy (d3-1)))- ,Left (valToTerm kn)- ,Left (mkApps (vecAppendPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Right (LitTy (NumTy 1))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])- ,Left (mkApps (Data snatDc)- [Right (LitTy (NumTy (d3-1)))- ,Left (Literal (NaturalLiteral (d3-1)))])- ]- _ -> Nothing-- "Clash.Sized.Vector.rotateRightS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a- | isSubj- , nTy : aTy : _ : _ <- tys- , kn : xs : d : _ <- args- , DC dc _ <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- n' | DC snatDc [_,Left d'] <- d- , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf tcm isSubj (setTerm d' $ stackClear mach)- -> case (d2 `mod` n) of- 0 -> reduce (valToTerm xs)- d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- in reduceWHNF' mach2 $- mkApps (Prim pInfo)- [Right nTy- ,Right aTy- ,Right (LitTy (NumTy (d3-1)))- ,Left (valToTerm kn)- ,Left (mkVecCons dc aTy n- (mkApps (vecLastPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (valToTerm xs)])- (mkApps (vecInitPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (valToTerm xs)]))- ,Left (mkApps (Data snatDc)- [Right (LitTy (NumTy (d3-1)))- ,Left (Literal (NaturalLiteral (d3-1)))])- ]- _ -> Nothing--- Element-wise operations--- - mapping- "Clash.Sized.Vector.map" -- :: (a -> b) -> Vec n a -> Vec n b- | isSubj- , DC dc vArgs <- args !! 1- , aTy : bTy : nTy : _ <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc bTy)- n' -> reduce $- mkVecCons dc bTy n'- (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])- (mkApps (Prim pInfo)- [Right aTy- ,Right bTy- ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm (args !! 0))- ,Left (Either.lefts vArgs !! 2)])- "Clash.Sized.Vector.imap" -- :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b- | isSubj- , nTy : aTy : bTy : _ <- tys- , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)- , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)- , Right n <- runExcept (tyNatSize tcm nTy)- , let iLit = mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0- -> reduceWHNF $- mkApps (Prim (PrimInfo "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm) WorkNever))- [Right nTy- ,Right nTy- ,Right aTy- ,Right bTy- ,Left iLit- ,Left (valToTerm (args !! 1))- ,Left (valToTerm (args !! 2))- ]-- "Clash.Sized.Vector.imap_go"- | isSubj- , nTy : mTy : aTy : bTy : _ <- tys- , n : f : xs : _ <- args- , DC dc vArgs <- xs- , Right n' <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- -> case m of- 0 -> reduce (mkVecNil dc bTy)- m' -> let (tyArgs,_) = splitFunForallTy ty- TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 0)- iLit = mkIndexLit (Either.rights tyArgs !! 0) nTy n' 1- in reduce $ mkVecCons dc bTy m'- (mkApps (valToTerm f) [Left (valToTerm n),Left (Either.lefts vArgs !! 1)])- (mkApps (Prim pInfo)- [Right nTy- ,Right (LitTy (NumTy (m'-1)))- ,Right aTy- ,Right bTy- ,Left (mkApps (Prim (PrimInfo "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm) WorkVariable))- [Right nTy- ,Left (Literal (NaturalLiteral n'))- ,Left (valToTerm n)- ,Left iLit- ])- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ])---- - Zipping- "Clash.Sized.Vector.zipWith" -- :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c- | isSubj- , aTy : bTy : cTy : nTy : _ <- tys- , f : xs : ys : _ <- args- , DC dc vArgs <- xs- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc cTy)- n' -> reduce $ mkVecCons dc cTy n'- (mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)- ,Left (mkApps (vecHeadPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right bTy- ,Left (valToTerm ys)- ])- ])- (mkApps (Prim pInfo)- [Right aTy- ,Right bTy- ,Right cTy- ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (vecTailPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right bTy- ,Left (valToTerm ys)- ])])---- Folding- "Clash.Sized.Vector.foldr" -- :: (a -> b -> b) -> b -> Vec n a -> b- | isSubj- , aTy : bTy : nTy : _ <- tys- , f : z : xs : _ <- args- , DC _ vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (valToTerm z)- _ -> reduceWHNF $- mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim pInfo)- [Right aTy- ,Right bTy- ,Right (LitTy (NumTy (n-1)))- ,Left (valToTerm f)- ,Left (valToTerm z)- ,Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.fold" -- :: (a -> a -> a) -> Vec (n + 1) a -> a- | isSubj- , aTy : nTy : _ <- tys- , f : vs : _ <- args- , DC _ vArgs <- vs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduceWHNF (Either.lefts vArgs !! 1)- _ -> let (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- n' = n+1- m = n' `div` 2- n1 = n' - m- mTy = LitTy (NumTy m)- m'ty = LitTy (NumTy (m-1))- n1mTy = LitTy (NumTy n1)- n1m'ty = LitTy (NumTy (n1-1))- splitAtCall =- mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever))- [Right mTy- ,Right n1mTy- ,Right aTy- ,Left (Literal (NaturalLiteral m))- ,Left (valToTerm vs)- ]- mVecTy = mkTyConApp vecTcNm [mTy,aTy]- n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- asNm = mkUnsafeSystemName "as" 0- bsNm = mkUnsafeSystemName "bs" 1- asId = mkLocalId mVecTy asNm- bsId = mkLocalId n1mVecTy bsNm- tupPat = DataPat tupDc [] [asId,bsId]- asAlt = (tupPat, (Var asId))- bsAlt = (tupPat, (Var bsId))- in reduceWHNF $- mkApps (valToTerm f)- [Left (mkApps (Prim pInfo)- [Right aTy- ,Right m'ty- ,Left (valToTerm f)- ,Left (Case splitAtCall mVecTy [asAlt])- ])- ,Left (mkApps (Prim pInfo)- [Right aTy- ,Right n1m'ty- ,Left (valToTerm f)- ,Left (Case splitAtCall n1mVecTy [bsAlt])- ])- ]--- "Clash.Sized.Vector.fold_split" -- :: Natural -> Vec (m + n) a -> (Vec m a, Vec n a)- | isSubj- , mTy : nTy : aTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- -> let -- Get the tuple data-constructor- ty1 = piResultTys tcm ty tys- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty1- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- -- Get the vector data-constructors- TyConApp vecTcNm _ = tyView (head tyArgs)- Just vecTc = lookupUniqMap vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- -- Recursive call to @splitAt@- splitAtRec v =- mkApps (Prim pInfo)- [Right (LitTy (NumTy (m-1)))- ,Right nTy- ,Right aTy- ,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- lNm = mkUnsafeSystemName "l" 0- rNm = mkUnsafeSystemName "r" 1- lId = mkLocalId m1VecTy lNm- rId = mkLocalId nVecTy rNm- tupPat = DataPat tupDc [] [lId,rId]- lAlt = (tupPat, (Var lId))- rAlt = (tupPat, (Var rId))- in case m of- -- (Nil,v)- 0 -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecNil nilCon aTy)- , Left (valToTerm (last args))- ]- -- (x:xs) <- v- m' | DC _ vArgs <- last args- -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))- -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)- (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))- , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])- ]- -- v doesn't reduce to a data-constructor- _ -> Nothing--- - Specialised folds- "Clash.Sized.Vector.dfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : z : xs : _ <- args- , DC _ vArgs <- xs- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduce (valToTerm z)- _ -> let (tyArgs,_) = splitFunForallTy ty- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- k'ty = LitTy (NumTy (k'-1))- in reduceWHNF $- mkApps (valToTerm f)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm z)- ,Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.dtfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : g : xs : _ <- args- , DC _ vArgs <- xs- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])- _ -> let (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = lookupUniqMap snatTcNm tcm- [snatDc] = tyConDataCons snatTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- k'ty = LitTy (NumTy (k'-1))- k2ty = LitTy (NumTy (2^(k'-1)))- splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right k2ty- ,Right k2ty- ,Right aTy- ,Left (mkApps (Data snatDc)- [Right k2ty- ,Left (Literal (NaturalLiteral (2^(k'-1))))])- ,Left (valToTerm xs)- ]- xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- xsLNm = mkUnsafeSystemName "xsL" 0- xsRNm = mkUnsafeSystemName "xsR" 1- xsLId = mkLocalId k2ty xsLNm- xsRId = mkLocalId k2ty xsRNm- tupPat = DataPat tupDc [] [xsLId,xsRId]- asAlt = (tupPat, (Var xsLId))- bsAlt = (tupPat, (Var xsRId))- in reduceWHNF $- mkApps (valToTerm g)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Case splitAtCall xsSVecTy [asAlt])])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Case splitAtCall xsSVecTy [bsAlt])])- ]--- Misc- "Clash.Sized.Vector.lazyV"- | isSubj- , nTy : aTy : _ <- tys- , _ : xs : _ <- args- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let (Just vecTc) = lookupUniqMap vecTcNm tcm- [nilCon,_] = tyConDataCons vecTc- in reduce (mkVecNil nilCon aTy)- n' -> let (Just vecTc) = lookupUniqMap vecTcNm tcm- [_,consCon] = tyConDataCons vecTc- in reduce $ mkVecCons consCon aTy n'- (mkApps (vecHeadPrim vecTcNm)- [ Right (LitTy (NumTy (n' - 1)))- , Right aTy- , Left (valToTerm xs)- ])- (mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n' - 1)))- , Right aTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (mkApps (vecTailPrim vecTcNm)- [ Right (LitTy (NumTy (n'-1)))- , Right aTy- , Left (valToTerm xs)- ])- ])--- Traversable- "Clash.Sized.Vector.traverse#"- | isSubj- , aTy : fTy : bTy : nTy : _ <- tys- , apDict : f : xs : _ <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 1) ids- in reduceWHNF' (mach { mSupply = ids' }) $- mkApps pureF- [Right (mkTyConApp (vecTcNm) [nTy,bTy])- ,Left (mkVecNil dc bTy)]- _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do- fDict <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 0- fmapF' <- mkSelectorCase $(curLoc) is0 tcm fDict 1 0- apF' <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 2- return (fmapF',apF')- n'ty = LitTy (NumTy (n-1))- Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]- in reduceWHNF' (mach { mSupply = ids' }) $- mkApps apF- [Right (mkTyConApp vecTcNm [n'ty,bTy])- ,Right (mkTyConApp vecTcNm [nTy,bTy])- ,Left (mkApps fmapF- [Right bTy- ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])- (mkTyConApp vecTcNm [nTy,bTy]))- ,Left (mkApps (Data dc)- [Right nTy- ,Right bTy- ,Right n'ty- ,Left (primCo consCoTy)])- ,Left (mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)])- ])- ,Left (mkApps (Prim pInfo)- [Right aTy- ,Right fTy- ,Right bTy- ,Right n'ty- ,Left (valToTerm apDict)- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ])- ]- where- (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)- (ids, is0) = (mSupply mach, mScopeNames mach)---- BitPack- "Clash.Sized.Vector.concatBitVector#"- | isSubj- , nTy : mTy : _ <- tys- , _ : km : v : _ <- args- , DC _ vArgs <- v- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo 0 0)- n' | Right m <- runExcept (tyNatSize tcm mTy)- , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty- -> reduceWHNF $- mkApps (bvAppendPrim bvTcNm)- [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])- , Right mTy- , Left (Literal (NaturalLiteral ((n'-1)*m)))- , Left (Either.lefts vArgs !! 1)- , Left (mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n'-1)))- , Right mTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (valToTerm km)- , Left (Either.lefts vArgs !! 2)- ])- ]- _ -> Nothing- "Clash.Sized.Vector.unconcatBitVector#"- | isSubj- , nTy : mTy : _ <- tys- , _ : km : bv : _ <- args- , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty- , TyConApp bvTcNm _ <- tyView bvMTy- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 ->- let (Just vecTc) = lookupUniqMap vecTcNm tcm- [nilCon,_] = tyConDataCons vecTc- in reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))- n' | Right m <- runExcept (tyNatSize tcm mTy) ->- let Just vecTc = lookupUniqMap vecTcNm tcm- [_,consCon] = tyConDataCons vecTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- Just tupTc = lookupUniqMap tupTcNm tcm- [tupDc] = tyConDataCons tupTc- splitCall =- mkApps (bvSplitPrim bvTcNm)- [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])- , Right mTy- , Left (Literal (NaturalLiteral ((n'-1)*m)))- , Left (valToTerm bv)- ]- mBVTy = mkTyConApp bvTcNm [mTy]- n1BVTy = mkTyConApp bvTcNm- [mkTyConApp typeNatMul- [LitTy (NumTy (n'-1))- ,mTy]]- -- Guaranteed no capture, so okay to use unsafe name generation- xNm = mkUnsafeSystemName "x" 0- bvNm = mkUnsafeSystemName "bv'" 1- xId = mkLocalId mBVTy xNm- bvId = mkLocalId n1BVTy bvNm- tupPat = DataPat tupDc [] [xId,bvId]- xAlt = (tupPat, (Var xId))- bvAlt = (tupPat, (Var bvId))-- in reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'- (Case splitCall mBVTy [xAlt])- (mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n'-1)))- , Right mTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (valToTerm km)- , Left (Case splitCall n1BVTy [bvAlt])- ])- _ -> Nothing- _ -> Nothing- where- ty = primType pInfo-- checkNaturalRange1 nTy i f =- checkNaturalRange nTy [i]- (\[i'] -> naturalToNaturalLiteral (f i'))-- checkNaturalRange2 nTy i j f =- checkNaturalRange nTy [i, j]- (\[i', j'] -> naturalToNaturalLiteral (f i' j'))-- -- Check given integer's range. If any of them are less than zero, give up- -- and return an undefined type.- checkNaturalRange- :: Type- -- Type of GHC.Natural.Natural ^- -> [Integer]- -> ([Natural] -> Term)- -> Term- checkNaturalRange nTy natsAsInts f =- if any (<0) natsAsInts then- undefinedTm nTy- else- f (map fromInteger natsAsInts)-- reduce :: Term -> Maybe Machine- reduce 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)-- reduceWHNF e =- let mach1@Machine{mStack=[]} = whnf tcm isSubj (setTerm e $ stackClear mach)- in Just $ mach1 { mStack = mStack mach }-- reduceWHNF' mach1 e =- let mach2@Machine{mStack=[]} = whnf tcm isSubj (setTerm e mach1)- in Just $ mach2 { mStack = mStack mach }-- makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term- makeUndefinedIf wantToHandle tm =- case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of- Right b -> b- Left e -> trace (msg e) (undefinedTm resTy)- where- resTy = getResultTy tcm ty tys- selectException e | wantToHandle e = Just e- | otherwise = Nothing- msg e = unlines ["Warning: caught exception: \"" ++ show e ++ "\" while trying to evaluate: "- , showPpr (mkApps (Prim pInfo) (map (Left . valToTerm) args))- ]-- catchDivByZero = makeUndefinedIf (==DivideByZero)---- Helper functions for literals--pairOf :: (Value -> Maybe a) -> [Value] -> Maybe (a, a)-pairOf f [x, y] = (,) <$> f x <*> f y-pairOf _ _ = Nothing--listOf :: (Value -> Maybe a) -> [Value] -> [a]-listOf = mapMaybe--wrapUnsigned :: Integer -> Integer -> Integer-wrapUnsigned n i = i `mod` sz- where- sz = 1 `shiftL` fromInteger n--wrapSigned :: Integer -> Integer -> Integer-wrapSigned n i = if mask == 0 then 0 else res- where- mask = 1 `shiftL` fromInteger (n - 1)- res = case divMod i mask of- (s,i1) | even s -> i1- | otherwise -> i1 - mask--doubleLiterals' :: [Value] -> [Rational]-doubleLiterals' = listOf doubleLiteral--doubleLiteral :: Value -> Maybe Rational-doubleLiteral v = case v of- Lit (DoubleLiteral i) -> Just i- _ -> Nothing--floatLiterals' :: [Value] -> [Rational]-floatLiterals' = listOf floatLiteral--floatLiteral :: Value -> Maybe Rational-floatLiteral v = case v of- Lit (FloatLiteral i) -> Just i- _ -> Nothing--integerLiterals :: [Value] -> Maybe (Integer, Integer)-integerLiterals = pairOf integerLiteral--integerLiteral :: Value -> Maybe Integer-integerLiteral v =- case v of- Lit (IntegerLiteral i) -> Just i- DC dc [Left (Literal (IntLiteral i))]- | dcTag dc == 1- -> Just i- DC dc [Left (Literal (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))))]- | dcTag dc == 2- -> Just (Jp# (BN# ba))- | dcTag dc == 3- -> Just (Jn# (BN# ba))- _ -> Nothing--naturalLiterals :: [Value] -> Maybe (Integer, Integer)-naturalLiterals = pairOf naturalLiteral--naturalLiteral :: Value -> Maybe Integer-naturalLiteral v =- case v of- Lit (NaturalLiteral i) -> Just i- DC dc [Left (Literal (WordLiteral i))]- | dcTag dc == 1- -> Just i- DC dc [Left (Literal (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))))]- | dcTag dc == 2- -> Just (Jp# (BN# ba))- _ -> Nothing--integerLiterals' :: [Value] -> [Integer]-integerLiterals' = listOf integerLiteral--naturalLiterals' :: [Value] -> [Integer]-naturalLiterals' = listOf naturalLiteral--intLiterals :: [Value] -> Maybe (Integer,Integer)-intLiterals = pairOf intLiteral--intLiterals' :: [Value] -> [Integer]-intLiterals' = listOf intLiteral--intLiteral :: Value -> Maybe Integer-intLiteral x = case x of- Lit (IntLiteral i) -> Just i- _ -> Nothing--intCLiteral :: Value -> Maybe Integer-intCLiteral v = case v of- (DC _ [Left (Literal (IntLiteral i))]) -> Just i- _ -> Nothing--intCLiterals :: [Value] -> Maybe (Integer, Integer)-intCLiterals = pairOf intCLiteral--wordLiterals :: [Value] -> Maybe (Integer,Integer)-wordLiterals = pairOf wordLiteral--wordLiterals' :: [Value] -> [Integer]-wordLiterals' = listOf wordLiteral--wordLiteral :: Value -> Maybe Integer-wordLiteral x = case x of- Lit (WordLiteral i) -> Just i- _ -> Nothing--charLiterals :: [Value] -> Maybe (Char,Char)-charLiterals = pairOf charLiteral--charLiterals' :: [Value] -> [Char]-charLiterals' = listOf charLiteral--charLiteral :: Value -> Maybe Char-charLiteral x = case x of- Lit (CharLiteral c) -> Just c- _ -> Nothing--sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)-sizedLiterals szCon = pairOf (sizedLiteral szCon)--sizedLiterals' :: Text -> [Value] -> [Integer]-sizedLiterals' szCon = listOf (sizedLiteral szCon)--sizedLiteral :: Text -> Value -> Maybe Integer-sizedLiteral szCon val = case val of- PrimVal p _ [_, Lit (IntegerLiteral i)]- | primName p == szCon -> Just i- _ -> Nothing--bitLiterals- :: [Value]- -> [(Integer,Integer)]-bitLiterals = map normalizeBit . mapMaybe go- where- normalizeBit (msk,v) = (msk .&. 1, v .&. 1)- go val = case val of- PrimVal p _ [Lit (WordLiteral m), Lit (IntegerLiteral i)]- | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"- -> Just (m,i)- _ -> Nothing--indexLiterals, signedLiterals, unsignedLiterals- :: [Value] -> Maybe (Integer,Integer)-indexLiterals = sizedLiterals "Clash.Sized.Internal.Index.fromInteger#"-signedLiterals = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLiterals = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#"--indexLiterals', signedLiterals', unsignedLiterals'- :: [Value] -> [Integer]-indexLiterals' = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#"-signedLiterals' = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLiterals' = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#"--bitVectorLiterals'- :: [Value] -> [(Integer,Integer)]-bitVectorLiterals' = listOf bitVectorLiteral--bitVectorLiteral :: Value -> Maybe (Integer, Integer)-bitVectorLiteral val = case val of- (PrimVal p _ [_, Lit (NaturalLiteral m), Lit (IntegerLiteral i)])- | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (m, i)- _ -> Nothing--toBV :: (Integer,Integer) -> BitVector n-toBV (mask,val) = BV (fromInteger mask) (fromInteger val)--splitBV :: BitVector n -> (Integer,Integer)-splitBV (BV msk val) = (toInteger msk, toInteger val)--toBit :: (Integer,Integer) -> Bit-toBit (mask,val) = Bit (fromInteger mask) (fromInteger val)--valArgs- :: Value- -> Maybe [Term]-valArgs v =- case v of- PrimVal _ _ vs -> Just (fmap valToTerm vs)- DC _ args -> Just (Either.lefts args)- _ -> Nothing---- Tries to match literal arguments to a function like--- (Unsigned.shiftL# :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)-sizedLitIntLit- :: Text -> TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,Integer,Integer)-sizedLitIntLit szCon tcm tys args- | Just (nTy,kn) <- extractKnownNat tcm tys- , [_- ,PrimVal p _ [_,Lit (IntegerLiteral i)]- ,valArgs -> Just [Literal (IntLiteral j)]- ] <- args- , primName p == szCon- = Just (nTy,kn,i,j)- | otherwise- = Nothing--signedLitIntLit, unsignedLitIntLit- :: TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,Integer,Integer)-signedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Unsigned.fromInteger#"--bitVectorLitIntLit- :: TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,(Integer,Integer),Integer)-bitVectorLitIntLit tcm tys args- | Just (nTy,kn) <- extractKnownNat tcm tys- , [_- ,PrimVal p _ [_,Lit (NaturalLiteral m),Lit (IntegerLiteral i)]- ,valArgs -> Just [Literal (IntLiteral j)]- ] <- args- , primName p == "Clash.Sized.Internal.BitVector.fromInteger#"- = Just (nTy,kn,(m,i),j)- | otherwise- = Nothing---- From an argument list to function of type--- forall n. KnownNat n => ...--- extract (nTy,nInt)--- where nTy is the Type of n--- and nInt is its value as an Integer-extractKnownNat :: TyConMap -> [Type] -> Maybe (Type, Integer)-extractKnownNat tcm tys = case tys of- nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)- -> Just (nTy, nInt)- _ -> Nothing---- From an argument list to function of type--- forall n m o .. . (KnownNat n, KnownNat m, KnownNat o, ..) => ...--- extract [(nTy,nInt), (mTy,mInt), (oTy,oInt)]--- where nTy is the Type of n--- and nInt is its value as an Integer-extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]-extractKnownNats tcm =- mapMaybe (extractKnownNat tcm . pure)---- Construct a constant term of a sized type-mkSizedLit- :: (Type -> Term)- -- ^ Type constructor?- -> Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ Value to construct- -> Term-mkSizedLit conPrim ty nTy kn val =- mkApps- (conPrim sTy)- [ Right nTy- , Left (Literal (NaturalLiteral kn))- , Left (Literal (IntegerLiteral val)) ]- where- (_,sTy) = splitFunForallTy ty--mkBitLit- :: Type- -- ^ Result type- -> Integer- -- ^ Mask- -> Integer- -- ^ Value- -> Term-mkBitLit ty msk val =- mkApps (bConPrim sTy) [ Left (Literal (WordLiteral (msk .&. 1)))- , Left (Literal (IntegerLiteral (val .&. 1)))]- where- (_,sTy) = splitFunForallTy ty--mkSignedLit, mkUnsignedLit- :: Type- -- Result type- -> Type- -- forall n.- -> Integer- -- KnownNat n- -> Integer- -- Value- -> Term-mkSignedLit = mkSizedLit signedConPrim-mkUnsignedLit = mkSizedLit unsignedConPrim--mkBitVectorLit- :: Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ mask- -> Integer- -- ^ Value to construct- -> Term-mkBitVectorLit ty nTy kn mask val- = mkApps (bvConPrim sTy)- [Right nTy- ,Left (Literal (NaturalLiteral kn))- ,Left (Literal (NaturalLiteral mask))- ,Left (Literal (IntegerLiteral val))]- where- (_,sTy) = splitFunForallTy ty--mkIndexLitE- :: Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ Value to construct- -> Either Term Term- -- ^ Either undefined (if given value is out of bounds of given type) or term- -- representing literal-mkIndexLitE rTy nTy kn val- | val >= 0- , val < kn- = Right (mkSizedLit indexConPrim rTy nTy kn val)- | otherwise- = Left (undefinedTm (mkTyConApp indexTcNm [nTy]))- where- TyConApp indexTcNm _ = tyView (snd (splitFunForallTy rTy))--mkIndexLit- :: Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ Value to construct- -> Term-mkIndexLit rTy nTy kn val =- either id id (mkIndexLitE rTy nTy kn val)--mkBitVectorLit'- :: (Type, Type, Integer)- -- ^ (result type, forall n., KnownNat n)- -> Integer- -- ^ Mask- -> Integer- -- ^ Value- -> Term-mkBitVectorLit' (ty,nTy,kn) = mkBitVectorLit ty nTy kn--mkIndexLit'- :: (Type, Type, Integer)- -- ^ (result type, forall n., KnownNat n)- -> Integer- -- ^ value- -> Term-mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn---- | Create a vector of supplied elements-mkVecCons- :: DataCon- -- ^ The Cons (:>) constructor- -> Type- -- ^ Element type- -> Integer- -- ^ Length of the vector- -> Term- -- ^ head of the vector- -> Term- -- ^ tail of the vector- -> Term-mkVecCons consCon resTy n h t =- mkApps (Data consCon) [Right (LitTy (NumTy n))- ,Right resTy- ,Right (LitTy (NumTy (n-1)))- ,Left (primCo consCoTy)- ,Left h- ,Left t]-- where- args = dataConInstArgTys consCon [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))]- Just (consCoTy : _) = args---- | Create an empty vector-mkVecNil- :: DataCon- -- ^ The Nil constructor- -> Type- -- ^ The element type- -> Term-mkVecNil nilCon resTy =- mkApps (Data nilCon) [Right (LitTy (NumTy 0))- ,Right resTy- ,Left (primCo nilCoTy)- ]- where- args = dataConInstArgTys nilCon [LitTy (NumTy 0),resTy]- Just (nilCoTy : _ ) = args--boolToIntLiteral :: Bool -> Term-boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)--boolToBoolLiteral :: TyConMap -> Type -> Bool -> Term-boolToBoolLiteral tcm ty b =- let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty- (Just boolTc) = lookupUniqMap boolTcNm tcm- [falseDc,trueDc] = tyConDataCons boolTc- retDc = if b then trueDc else falseDc- in Data retDc--charToCharLiteral :: Char -> Term-charToCharLiteral = Literal . CharLiteral--integerToIntLiteral :: Integer -> Term-integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behavior--integerToWordLiteral :: Integer -> Term-integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behavior--integerToIntegerLiteral :: Integer -> Term-integerToIntegerLiteral = Literal . IntegerLiteral--naturalToNaturalLiteral :: Natural -> Term-naturalToNaturalLiteral = Literal . NaturalLiteral . toInteger--bConPrim :: Type -> Term-bConPrim (tyView -> TyConApp bTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever)- where- funTy = foldr1 mkFunTy [wordPrimTy,integerPrimTy,mkTyConApp bTcNm []]-bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--bvConPrim :: Type -> Term-bvConPrim (tyView -> TyConApp bvTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy nTV funTy) WorkNever)- where- funTy = foldr1 mkFunTy [naturalPrimTy,naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--indexConPrim :: Type -> Term-indexConPrim (tyView -> TyConApp indexTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy nTV funTy) WorkNever)- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--signedConPrim :: Type -> Term-signedConPrim (tyView -> TyConApp signedTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy nTV funTy) WorkNever)- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--unsignedConPrim :: Type -> Term-unsignedConPrim (tyView -> TyConApp unsignedTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy nTV funTy) WorkNever)- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"----- | Lift a binary function over 'Unsigned' values to be used as literal Evaluator-------liftUnsigned2 :: KnownNat n- => (Unsigned n -> Unsigned n -> Unsigned n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit--liftSigned2 :: KnownNat n- => (Signed n -> Signed n -> Signed n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftSigned2 = liftSized2 signedLiterals' mkSignedLit--liftBitVector2 :: KnownNat n- => (BitVector n -> BitVector n -> BitVector n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftBitVector2 f ty tcm tys args _p- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i,j] <- bitVectorLiterals' args- = let BV mask val = f (toBV i) (toBV j)- in Just $ mkBitVectorLit ty nTy kn (toInteger mask) (toInteger val)- | otherwise = Nothing--liftBitVector2Bool :: KnownNat n- => (BitVector n -> BitVector n -> Bool)- -> Type- -> TyConMap- -> [Value]- -> (Proxy n -> Maybe Term)-liftBitVector2Bool f ty tcm args _p- | [i,j] <- bitVectorLiterals' args- = let val = f (toBV i) (toBV j)- in Just $ boolToBoolLiteral tcm ty val- | otherwise = Nothing--liftSized2 :: (KnownNat n, Integral (sized n))- => ([Value] -> [Integer])- -- ^ literal argument extraction function- -> (Type -> Type -> Integer -> Integer -> Term)- -- ^ literal contruction function- -> (sized n -> sized n -> sized n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftSized2 extractLitArgs mkLit f ty tcm tys args p- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i,j] <- extractLitArgs args- = let val = runSizedF f i j p- in Just $ mkLit ty nTy kn val- | otherwise = Nothing---- | Helper to run a function over sized types on integers------ This only works on function of type (sized n -> sized n -> sized n)--- The resulting function must be executed with reifyNat-runSizedF- :: (KnownNat n, Integral (sized n))- => (sized n -> sized n -> sized n)- -- ^ function to run- -> Integer- -- ^ first argument- -> Integer- -- ^ second argument- -> (Proxy n -> Integer)-runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)--extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)-extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)- where- ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- TyConApp _ [resSizeTy] = tyView resTy- Right resSize = runExcept (tyNatSize tcm resSizeTy)--getResultTy- :: TyConMap- -> Type- -> [Type]- -> Type-getResultTy tcm ty tys = resTy- where- ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'--liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term-liftDDI f args = case doubleLiterals' args of- [i,j] -> Just $ runDDI f i j- _ -> Nothing-liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term-liftDDD f args = case doubleLiterals' args of- [i,j] -> Just $ runDDD f i j- _ -> Nothing-liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term-liftDD f args = case doubleLiterals' args of- [i] -> Just $ runDD f i- _ -> Nothing-runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term-runDDI f i j- = let !(D# a) = fromRational i- !(D# b) = fromRational j- r = f a b- in Literal . IntLiteral . toInteger $ I# r-runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term-runDDD f i j- = let !(D# a) = fromRational i- !(D# b) = fromRational j- r = f a b- in Literal . DoubleLiteral . toRational $ D# r-runDD :: (Double# -> Double#) -> Rational -> Term-runDD f i- = let !(D# a) = fromRational i- r = f a- in Literal . DoubleLiteral . toRational $ D# r--liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term-liftFFI f args = case floatLiterals' args of- [i,j] -> Just $ runFFI f i j- _ -> Nothing-liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term-liftFFF f args = case floatLiterals' args of- [i,j] -> Just $ runFFF f i j- _ -> Nothing-liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term-liftFF f args = case floatLiterals' args of- [i] -> Just $ runFF f i- _ -> Nothing-runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term-runFFI f i j- = let !(F# a) = fromRational i- !(F# b) = fromRational j- r = f a b- in Literal . IntLiteral . toInteger $ I# r-runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term-runFFF f i j- = let !(F# a) = fromRational i- !(F# b) = fromRational j- r = f a b- in Literal . FloatLiteral . toRational $ F# r-runFF :: (Float# -> Float#) -> Rational -> Term-runFF f i- = let !(F# a) = fromRational i- r = f a- in Literal . FloatLiteral . toRational $ F# r--vecHeadPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecHeadPrim vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever)--vecLastPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecLastPrim vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever)--vecHeadTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecHeadTy vecNm =- ForAllTy nTV (- ForAllTy aTV (- mkFunTy- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy nTV- ,LitTy (NumTy 1)]- ,VarTy aTV- ])- (VarTy aTV)))- where- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)--vecTailPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecTailPrim vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever)--vecInitPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecInitPrim vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever)--vecTailTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecTailTy vecNm =- ForAllTy nTV (- ForAllTy aTV (- mkFunTy- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy nTV- ,LitTy (NumTy 1)]- ,VarTy aTV- ])- (mkTyConApp vecNm [VarTy nTV- ,VarTy aTV- ])))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)--splitAtPrim- :: TyConName- -- ^ SNat TyCon name- -> TyConName- -- ^ Vec TyCon name- -> Term-splitAtPrim snatTcNm vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm) WorkNever)--splitAtTy- :: TyConName- -- ^ SNat TyCon name- -> TyConName- -- ^ Vec TyCon name- -> Type-splitAtTy snatNm vecNm =- ForAllTy mTV (- ForAllTy nTV (- ForAllTy aTV (- mkFunTy- (mkTyConApp snatNm [VarTy mTV])- (mkFunTy- (mkTyConApp vecNm- [mkTyConApp typeNatAdd- [VarTy mTV- ,VarTy nTV]- ,VarTy aTV])- (mkTyConApp tupNm- [mkTyConApp vecNm- [VarTy mTV- ,VarTy aTV]- ,mkTyConApp vecNm- [VarTy nTV- ,VarTy aTV]])))))- where- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--foldSplitAtTy- :: TyConName- -- ^ Vec TyCon name- -> Type-foldSplitAtTy vecNm =- ForAllTy mTV (- ForAllTy nTV (- ForAllTy aTV (- mkFunTy- naturalPrimTy- (mkFunTy- (mkTyConApp vecNm- [mkTyConApp typeNatAdd- [VarTy mTV- ,VarTy nTV]- ,VarTy aTV])- (mkTyConApp tupNm- [mkTyConApp vecNm- [VarTy mTV- ,VarTy aTV]- ,mkTyConApp vecNm- [VarTy nTV- ,VarTy aTV]])))))- where- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--vecAppendPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecAppendPrim vecNm =- Prim (PrimInfo "Clash.Sized.Vector.++" (vecAppendTy vecNm) WorkNever)--vecAppendTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecAppendTy vecNm =- ForAllTy nTV (- ForAllTy aTV (- ForAllTy mTV (- mkFunTy- (mkTyConApp vecNm [VarTy nTV- ,VarTy aTV- ])- (mkFunTy- (mkTyConApp vecNm [VarTy mTV- ,VarTy aTV- ])- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy nTV- ,VarTy mTV]- ,VarTy aTV- ])))))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 2)--vecZipWithPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecZipWithPrim vecNm =- Prim (PrimInfo "Clash.Sized.Vector.zipWith" (vecZipWithTy vecNm) WorkNever)--vecZipWithTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecZipWithTy vecNm =- ForAllTy aTV (- ForAllTy bTV (- ForAllTy cTV (- ForAllTy nTV (- mkFunTy- (mkFunTy aTy (mkFunTy bTy cTy))- (mkFunTy- (mkTyConApp vecNm [nTy,aTy])- (mkFunTy- (mkTyConApp vecNm [nTy,bTy])- (mkTyConApp vecNm [nTy,cTy])))))))- where- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)- bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)- cTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "c" 2)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 3)- aTy = VarTy aTV- bTy = VarTy bTV- cTy = VarTy cTV- nTy = VarTy nTV--vecImapGoTy- :: TyConName- -- ^ Vec TyCon name- -> TyConName- -- ^ Index TyCon name- -> Type-vecImapGoTy vecTcNm indexTcNm =- ForAllTy nTV (- ForAllTy mTV (- ForAllTy aTV (- ForAllTy bTV (- mkFunTy indexTy- (mkFunTy fTy- (mkFunTy vecATy vecBTy))))))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)- bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 3)- indexTy = mkTyConApp indexTcNm [nTy]- nTy = VarTy nTV- mTy = VarTy mTV- fTy = mkFunTy indexTy (mkFunTy aTy bTy)- aTy = VarTy aTV- bTy = VarTy bTV- vecATy = mkTyConApp vecTcNm [mTy,aTy]- vecBTy = mkTyConApp vecTcNm [mTy,bTy]--indexAddTy- :: TyConName- -- ^ Index TyCon name- -> Type-indexAddTy indexTcNm =- ForAllTy nTV (- mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy)))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- indexTy = mkTyConApp indexTcNm [VarTy nTV]--bvAppendPrim- :: TyConName- -- ^ BitVector TyCon Name- -> Term-bvAppendPrim bvTcNm =- Prim (PrimInfo "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm) WorkNever)--bvAppendTy- :: TyConName- -- ^ BitVector TyCon Name- -> Type-bvAppendTy bvNm =- ForAllTy mTV (- ForAllTy nTV (- mkFunTy naturalPrimTy (mkFunTy- (mkTyConApp bvNm [VarTy nTV])- (mkFunTy- (mkTyConApp bvNm [VarTy mTV])- (mkTyConApp bvNm [mkTyConApp typeNatAdd- [VarTy nTV- ,VarTy mTV]])))))- where- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)--bvSplitPrim- :: TyConName- -- ^ BitVector TyCon Name- -> Term-bvSplitPrim bvTcNm =- Prim (PrimInfo "Clash.Sized.Internal.BitVector.split#" (bvSplitTy bvTcNm) WorkNever)--bvSplitTy- :: TyConName- -- ^ BitVector TyCon Name- -> Type-bvSplitTy bvNm =- ForAllTy nTV (- ForAllTy mTV (- mkFunTy naturalPrimTy (mkFunTy- (mkTyConApp bvNm [mkTyConApp typeNatAdd- [VarTy mTV- ,VarTy nTV]])- (mkTyConApp tupNm [mkTyConApp bvNm [VarTy mTV]- ,mkTyConApp bvNm [VarTy nTV]]))))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--typeNatAdd :: TyConName-typeNatAdd = Name User- "GHC.TypeNats.+"- (getKey typeNatAddTyFamNameKey)- wiredInSrcSpan---typeNatMul :: TyConName-typeNatMul = Name User- "GHC.TypeNats.*"- (getKey typeNatMulTyFamNameKey)- wiredInSrcSpan--typeNatSub :: TyConName-typeNatSub = Name User- "GHC.TypeNats.-"- (getKey typeNatSubTyFamNameKey)- wiredInSrcSpan--ghcTyconToTyConName- :: TyCon.TyCon- -> TyConName-ghcTyconToTyConName tc =- Name User n' (getKey (TyCon.tyConUnique tc)) (getSrcSpan n)- where- n' = fromMaybe "_INTERNAL_" (modNameM n) `Text.append`- ('.' `Text.cons` Text.pack occName)- occName = occNameString $ nameOccName n- n = TyCon.tyConName tc--svoid :: (State# RealWorld -> State# RealWorld) -> IO ()-svoid m0 = IO (\s -> case m0 s of s' -> (# s', () #))--isTrueDC,isFalseDC :: DataCon -> Bool-isTrueDC dc = dcUniq dc == getKey trueDataConKey-isFalseDC dc = dcUniq dc == getKey falseDataConKey+ Copyright : (C) 2017, Google Inc.+ License : BSD2 (see the file LICENSE)+ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++ Call-by-need evaluator based on the evaluator described in:++ Maximilian Bolingbroke, Simon Peyton Jones, "Supercompilation by evaluation",+ Haskell '10, Baltimore, Maryland, USA.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.GHC.Evaluator where++import Prelude hiding (lookup)++import Control.Concurrent.Supply (Supply, freshId)+import Data.Either (lefts,rights)+import Data.List (foldl',mapAccumL)+import qualified Data.Primitive.ByteArray as BA+import qualified Data.Text as Text+#if MIN_VERSION_base(4,15,0)+import GHC.Num.Integer (Integer (..))+#else+import GHC.Integer.GMP.Internals+ (Integer (..), BigNat (..))+#endif++import Clash.Core.DataCon+import Clash.Core.Evaluator.Types+import Clash.Core.FreeVars+import Clash.Core.Literal+import Clash.Core.Name+import Clash.Core.Pretty+import Clash.Core.Subst+import Clash.Core.Term+import Clash.Core.TermInfo+import Clash.Core.TyCon+import Clash.Core.Type+import Clash.Core.Util+import Clash.Core.Var+import Clash.Core.VarEnv+import Clash.Debug+import Clash.Unique+import Clash.Util (curLoc)++import Clash.GHC.Evaluator.Primitive++evaluator :: Evaluator+evaluator = Evaluator+ { step = ghcStep+ , unwind = ghcUnwind+ , primStep = ghcPrimStep+ , primUnwind = ghcPrimUnwind+ }++{- [Note: forcing special primitives]+Clash uses the `whnf` function in two places (for now):++ 1. The case-of-known-constructor transformation+ 2. The reduceConstant transformation++The first transformation is needed to reach the required normal form. The+second transformation is more of cleanup transformation, so non-essential.++Normally, `whnf` would force the evaluation of all primitives, which is needed+in the `case-of-known-constructor` transformation. However, there are some+primitives which we want to leave unevaluated in the `reduceConstant`+transformation. Such primitives are:++ - Primitives such as `Clash.Sized.Vector.transpose`, `Clash.Sized.Vector.map`,+ etc. that do not reduce to an expression in normal form. Where the+ `reduceConstant` transformation is supposed to be normal-form preserving.+ - Primitives such as `GHC.Int.I8#`, `GHC.Word.W32#`, etc. which seem like+ wrappers around a 64-bit literal, but actually perform truncation to the+ desired bit-size.++This is why the Primitive Evaluator gets a flag telling whether it should+evaluate these special primitives.+-}++stepVar :: Id -> Step+stepVar i m _+ | Just e <- heapLookup LocalId i m+ = go LocalId e++ | Just e <- heapLookup GlobalId i m+ , isGlobalId i+ = go GlobalId e++ | otherwise+ = Nothing+ where+ go s e =+ let term = deShadowTerm (mScopeNames m) (tickExpr e)+ in Just . setTerm term . stackPush (Update s i) $ heapDelete s i m++ -- Removing the heap-bound value on a force ensures we do not get stuck on+ -- expressions such as: "let x = x in x"+ tickExpr = Tick (NameMod PrefixName (LitTy . SymTy $ toStr i))+ unQualName = snd . Text.breakOnEnd "."+ toStr = Text.unpack . unQualName . flip Text.snoc '_' . nameOcc . varName++stepData :: DataCon -> Step+stepData dc = ghcUnwind (DC dc [])++stepLiteral :: Literal -> Step+stepLiteral l = ghcUnwind (Lit l)++stepPrim :: PrimInfo -> Step+stepPrim pInfo m tcm+ | primName pInfo == "GHC.Prim.realWorld#" =+ ghcUnwind (PrimVal pInfo [] []) m tcm++ | otherwise =+ case fst $ splitFunForallTy (primType pInfo) of+ [] -> ghcPrimStep tcm (forcePrims m) pInfo [] [] m+ tys -> newBinder tys (Prim pInfo) m tcm++stepLam :: Id -> Term -> Step+stepLam x e = ghcUnwind (Lambda x e)++stepTyLam :: TyVar -> Term -> Step+stepTyLam x e = ghcUnwind (TyLambda x e)++stepApp :: Term -> Term -> Step+stepApp x y m tcm =+ case term of+ Data dc ->+ let tys = fst $ splitFunForallTy (dcType dc)+ in case compare (length args) (length tys) of+ EQ -> ghcUnwind (DC dc args) m tcm+ LT -> newBinder tys' (App x y) m tcm+ GT -> error "Overapplied DC"++ Prim p ->+ let tys = fst $ splitFunForallTy (primType p)+ in case compare (length args) (length tys) of+ EQ -> case lefts args of+ -- We make boolean conjunction and disjunction extra lazy by+ -- deferring the evaluation of the arguments during the evaluation+ -- of the primop rule.+ --+ -- This allows us to implement:+ --+ -- x && True --> x+ -- x && False --> False+ -- x || True --> True+ -- x || False --> x+ --+ -- even when that 'x' is _|_. This makes the evaluation+ -- rule lazier than the actual Haskel implementations which+ -- are strict in the first argument and lazy in the second.+ [a0, a1] | primName p `elem` ["GHC.Classes.&&","GHC.Classes.||"] ->+ let (m0,i) = newLetBinding tcm m a0+ (m1,j) = newLetBinding tcm m0 a1+ in ghcPrimStep tcm (forcePrims m) p [] [Suspend (Var i), Suspend (Var j)] m1++ (e':es) ->+ Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m++ _ -> error "internal error"++ LT -> newBinder tys' (App x y) m tcm++ GT -> let (m0, n) = newLetBinding tcm m y+ in Just . setTerm x $ stackPush (Apply n) m0++ _ -> let (m0, n) = newLetBinding tcm m y+ in Just . setTerm x $ stackPush (Apply n) m0+ where+ (term, args, _) = collectArgsTicks (App x y)+ tys' = fst . splitFunForallTy . termType tcm $ App x y++stepTyApp :: Term -> Type -> Step+stepTyApp x ty m tcm =+ case term of+ Data dc ->+ let tys = fst $ splitFunForallTy (dcType dc)+ in case compare (length args) (length tys) of+ EQ -> ghcUnwind (DC dc args) m tcm+ LT -> newBinder tys' (TyApp x ty) m tcm+ GT -> error "Overapplied DC"++ Prim p ->+ let tys = fst $ splitFunForallTy (primType p)+ in case compare (length args) (length tys) of+ EQ -> case lefts args of+ [] | primName p `elem` [ "Clash.Transformations.removedArg"+ , "Clash.Transformations.undefined" ] ->+ ghcUnwind (PrimVal p (rights args) []) m tcm++ | otherwise ->+ ghcPrimStep tcm (forcePrims m) p (rights args) [] m++ (e':es) ->+ Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m++ LT -> newBinder tys' (TyApp x ty) m tcm+ GT -> Just . setTerm x $ stackPush (Instantiate ty) m++ _ -> Just . setTerm x $ stackPush (Instantiate ty) m+ where+ (term, args, _) = collectArgsTicks (TyApp x ty)+ tys' = fst . splitFunForallTy . termType tcm $ TyApp x ty++stepLetRec :: [LetBinding] -> Term -> Step+stepLetRec bs x m _ = Just (allocate bs x m)++stepCase :: Term -> Type -> [Alt] -> Step+stepCase scrut ty alts m _ =+ Just . setTerm scrut $ stackPush (Scrutinise ty alts) m++-- TODO Support stepwise evaluation of casts.+--+stepCast :: Term -> Type -> Type -> Step+stepCast _ _ _ _ _ =+ flip trace Nothing $ unlines+ [ "WARNING: " <> $(curLoc) <> "Clash can't symbolically evaluate casts"+ , "Please file an issue at https://github.com/clash-lang/clash-compiler/issues"+ ]++stepTick :: TickInfo -> Term -> Step+stepTick tick x m _ =+ Just . setTerm x $ stackPush (Tickish tick) m++-- | Small-step operational semantics.+--+ghcStep :: Step+ghcStep m = case mTerm m of+ Var i -> stepVar i m+ Data dc -> stepData dc m+ Literal l -> stepLiteral l m+ Prim p -> stepPrim p m+ Lam v x -> stepLam v x m+ TyLam v x -> stepTyLam v x m+ App x y -> stepApp x y m+ TyApp x ty -> stepTyApp x ty m+ Letrec bs x -> stepLetRec bs x m+ Case s ty as -> stepCase s ty as m+ Cast x a b -> stepCast x a b m+ Tick t x -> stepTick t x m++-- | Take a list of types or type variables and create a lambda / type lambda+-- for each one around the given term.+--+newBinder :: [Either TyVar Type] -> Term -> Step+newBinder tys x m tcm =+ let (s', iss', x') = mkAbstr (mSupply m, mScopeNames m, x) tys+ m' = m { mSupply = s', mScopeNames = iss', mTerm = x' }+ in ghcStep m' tcm+ where+ mkAbstr = foldr go+ where+ go (Left tv) (s', iss', e') =+ (s', iss', TyLam tv (TyApp e' (VarTy tv)))++ go (Right ty) (s', iss', e') =+ let ((s'', _), n) = mkUniqSystemId (s', iss') ("x", ty)+ in (s'', iss' ,Lam n (App e' (Var n)))++newLetBinding+ :: TyConMap+ -> Machine+ -> Term+ -> (Machine, Id)+newLetBinding tcm m e+ | Var v <- e+ , heapContains LocalId v m+ = (m, v)++ | otherwise+ = let m' = heapInsert LocalId id_ e m+ in (m' { mSupply = ids', mScopeNames = is1 }, id_)+ where+ ty = termType tcm e+ ((ids', is1), id_) = mkUniqSystemId (mSupply m, mScopeNames m) ("x", ty)++-- | Unwind the stack by 1+ghcUnwind :: Unwind+ghcUnwind v m tcm = do+ (m', kf) <- stackPop m+ go kf m'+ where+ go (Update s x) = return . update s x v+ go (Apply x) = return . apply tcm v x+ go (Instantiate ty) = return . instantiate tcm v ty+ go (PrimApply p tys vs tms) = ghcPrimUnwind tcm p tys vs v tms+ go (Scrutinise altTy as) = return . scrutinise v altTy as+ go (Tickish _) = return . setTerm (valToTerm v)++-- | Update the Heap with the evaluated term+update :: IdScope -> Id -> Value -> Machine -> Machine+update s x (valToTerm -> term) =+ setTerm term . heapInsert s x term++-- | Apply a value to a function+apply :: TyConMap -> Value -> Id -> Machine -> Machine+apply _tcm (Lambda x' e) x m =+ setTerm (substTm "Evaluator.apply" subst e) m+ where+ subst = extendIdSubst subst0 x' (Var x)+ subst0 = mkSubst $ extendInScopeSet (mScopeNames m) x+apply tcm pVal@(PrimVal (PrimInfo{primType}) tys vs) x m+ | isUndefinedPrimVal pVal+ = setTerm (undefinedTm ty) m+ where+ ty = piResultTys tcm primType (tys ++ map (termType tcm . valToTerm) vs ++ [varType x])++apply _ v _ m = error $ "Evaluator.apply: Not a lambda: " ++ show v ++ "\n" ++ show m++-- | Instantiate a type-abstraction+instantiate :: TyConMap -> Value -> Type -> Machine -> Machine+instantiate _tcm (TyLambda x e) ty m =+ setTerm (substTm "Evaluator.instantiate1" subst e) m+ where+ subst = extendTvSubst subst0 x ty+ subst0 = mkSubst iss0+ iss0 = mkInScopeSet (localFVsOfTerms [e] `unionUniqSet` tyFVsOfTypes [ty])+instantiate tcm pVal@(PrimVal (PrimInfo{primType}) tys []) ty m+ | isUndefinedPrimVal pVal+ = setTerm (undefinedTm (piResultTys tcm primType (tys ++ [ty]))) m++instantiate _ p _ _ = error $ "Evaluator.instantiate: Not a tylambda: " ++ show p++-- | Evaluate a case-expression+scrutinise :: Value -> Type -> [Alt] -> Machine -> Machine+scrutinise v _altTy [] m = setTerm (valToTerm v) m+-- [Note: empty case expressions]+--+-- Clash does not have empty case-expressions; instead, empty case-expressions+-- are used to indicate that the `whnf` function was called the context of a+-- case-expression, which means certain special primitives must be forced.+-- See also [Note: forcing special primitives]+scrutinise (Lit l) _altTy alts m = case alts of+ (DefaultPat, altE):alts1 -> setTerm (go altE alts1) m+ _ -> let term = go (error $ "Evaluator.scrutinise: no match "+ <> showPpr (Case (valToTerm (Lit l)) (ConstTy Arrow) alts)) alts+ in setTerm term m+ where+ go def [] = def+ go _ ((LitPat l1,altE):_) | l1 == l = altE+ go _ ((DataPat dc [] [x],altE):_)+ | IntegerLiteral l1 <- l+ , Just patE <- case dcTag dc of+ 1 | l1 >= ((-2)^(63::Int)) && l1 < 2^(63::Int) ->+ Just (IntLiteral l1)+ 2 | l1 >= (2^(63::Int)) ->+#if MIN_VERSION_base(4,15,0)+ let !(IP ba0) = l1+#else+ let !(Jp# !(BN# ba0)) = l1+#endif+ ba1 = BA.ByteArray ba0+ in Just (ByteArrayLiteral ba1)+ 3 | l1 < ((-2)^(63::Int)) ->+#if MIN_VERSION_base(4,15,0)+ let !(IN ba0) = l1+#else+ let !(Jn# !(BN# ba0)) = l1+#endif+ ba1 = BA.ByteArray ba0+ in Just (ByteArrayLiteral ba1)+ _ -> Nothing+ = let inScope = localFVsOfTerms [altE]+ subst0 = mkSubst (mkInScopeSet inScope)+ subst1 = extendIdSubst subst0 x (Literal patE)+ in substTm "Evaluator.scrutinise" subst1 altE+ | NaturalLiteral l1 <- l+ , Just patE <- case dcTag dc of+ 1 | l1 >= 0 && l1 < 2^(64::Int) ->+ Just (WordLiteral l1)+ 2 | l1 >= (2^(64::Int)) ->+#if MIN_VERSION_base(4,15,0)+ let !(IP ba0) = l1+#else+ let !(Jp# !(BN# ba0)) = l1+#endif+ ba1 = BA.ByteArray ba0+ in Just (ByteArrayLiteral ba1)+ _ -> Nothing+ = let inScope = localFVsOfTerms [altE]+ subst0 = mkSubst (mkInScopeSet inScope)+ subst1 = extendIdSubst subst0 x (Literal patE)+ in substTm "Evaluator.scrutinise" subst1 altE+ go def (_:alts1) = go def alts1++scrutinise (DC dc xs) _altTy alts m+ | altE:_ <- [substInAlt altDc tvs pxs xs altE+ | (DataPat altDc tvs pxs,altE) <- alts, altDc == dc ] +++ [altE | (DefaultPat,altE) <- alts ]+ = setTerm altE m++scrutinise v@(PrimVal p _ vs) altTy alts m+ | isUndefinedPrimVal v+ = setTerm (undefinedTm altTy) m++ | any (\case {(LitPat {},_) -> True; _ -> False}) alts+ = case alts of+ ((DefaultPat,altE):alts1) -> setTerm (go altE alts1) m+ _ -> let term = go (error $ "Evaluator.scrutinise: no match "+ <> showPpr (Case (valToTerm v) (ConstTy Arrow) alts)) alts+ in setTerm term m+ where+ go def [] = def+ go _ ((LitPat l1,altE):_) | l1 == l = altE+ go def (_:alts1) = go def alts1++ l = case primName p of+ "Clash.Sized.Internal.BitVector.fromInteger##"+ | [Lit (WordLiteral 0), Lit l0] <- vs -> l0+ "Clash.Sized.Internal.BitVector.fromInteger#"+ | [_,Lit (NaturalLiteral 0),Lit l0] <- vs -> l0+ "Clash.Sized.Internal.Index.fromInteger#"+ | [_,Lit l0] <- vs -> l0+ "Clash.Sized.Internal.Signed.fromInteger#"+ | [_,Lit l0] <- vs -> l0+ "Clash.Sized.Internal.Unsigned.fromInteger#"+ | [_,Lit l0] <- vs -> l0+ _ -> error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts))++scrutinise v _altTy alts _ =+ error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts))++substInAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term+substInAlt dc tvs xs args e = substTm "Evaluator.substInAlt" subst e+ where+ tys = rights args+ tms = lefts args+ substTyMap = zip tvs (drop (length (dcUnivTyVars dc)) tys)+ substTmMap = zip xs tms+ inScope = tyFVsOfTypes tys `unionVarSet` localFVsOfTerms (e:tms)+ subst = extendTvSubstList (extendIdSubstList subst0 substTmMap) substTyMap+ subst0 = mkSubst (mkInScopeSet inScope)++-- | Allocate let-bindings on the heap+allocate :: [LetBinding] -> Term -> Machine -> Machine+allocate xes e m =+ m { mHeapLocal = extendVarEnvList (mHeapLocal m) xes'+ , mSupply = ids'+ , mScopeNames = isN+ , mTerm = e'+ }+ where+ xNms = fmap fst xes+ is1 = extendInScopeSetList (mScopeNames m) xNms+ (ids', s) = mapAccumL (letSubst (mHeapLocal m)) (mSupply m) xNms+ (nms, s') = unzip s+ isN = extendInScopeSetList is1 nms+ subst = extendIdSubstList subst0 s'+ subst0 = mkSubst (foldl' extendInScopeSet is1 nms)+ xes' = zip nms (fmap (substTm "Evaluator.allocate0" subst . snd) xes)+ e' = substTm "Evaluator.allocate1" subst e++-- | Create a unique name and substitution for a let-binder+letSubst+ :: PureHeap+ -> Supply+ -> Id+ -> (Supply, (Id, (Id, Term)))+letSubst h acc id0 =+ let (acc',id1) = mkUniqueHeapId h acc id0+ in (acc',(id1,(id0,Var id1)))+ where+ mkUniqueHeapId :: PureHeap -> Supply -> Id -> (Supply, Id)+ mkUniqueHeapId h' ids x =+ maybe (ids', x') (const $ mkUniqueHeapId h' ids' x) (lookupVarEnv x' h')+ where+ (i,ids') = freshId ids+ x' = modifyVarName (`setUnique` i) x
+ src-ghc/Clash/GHC/Evaluator.hs-boot view
@@ -0,0 +1,12 @@+module Clash.GHC.Evaluator where++import Clash.Core.Term (Term)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Evaluator.Types (Step, Unwind, Machine)+import Clash.Core.Var (Id)++ghcStep :: Step+ghcUnwind :: Unwind++newLetBinding :: TyConMap -> Machine -> Term -> (Machine, Id)+
+ src-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -0,0 +1,4778 @@+{-|+ Copyright : (C) 2013-2016, University of Twente,+ 2016-2017, Myrtle Software Ltd,+ 2017 , QBayLogic, Google Inc.+ License : BSD2 (see the file LICENSE)+ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnboxedTuples #-}++module Clash.GHC.Evaluator.Primitive+ ( ghcPrimStep+ , ghcPrimUnwind+ , isUndefinedPrimVal+ ) where++import Control.Concurrent.Supply (Supply,freshId)+import Control.DeepSeq (force)+import Control.Exception (ArithException(..), Exception, tryJust, evaluate)+import Control.Monad.State.Strict (State, MonadState)+import qualified Control.Monad.State.Strict as State+import Control.Monad.Trans.Except (runExcept)+import Data.Bits+import Data.Char (chr,ord)+import qualified Data.Either as Either+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.List as List+import qualified Data.Primitive.ByteArray as BA+import Data.Proxy (Proxy)+import Data.Reflection (reifyNat)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Exts (IsList(..))+import GHC.Float+import GHC.Int+import GHC.Integer+ (decodeDoubleInteger,encodeDoubleInteger,compareInteger,orInteger,andInteger,+ xorInteger,complementInteger,absInteger,signumInteger)+#if MIN_VERSION_base(4,15,0)+import GHC.Num.Integer (Integer (..), integerEncodeFloat#)+#else+import GHC.Integer.GMP.Internals+ (Integer (..), BigNat (..))+#endif+#if MIN_VERSION_base(4,15,0)+import GHC.Num.Natural (naturalSubUnsafe)+#endif+import GHC.Natural+import GHC.Prim+import GHC.Real (Ratio (..))+import GHC.TypeLits (KnownNat)+import GHC.Types (IO (..))+import GHC.Word+import System.IO.Unsafe (unsafeDupablePerformIO)++#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Basic (Boxity (..))+import GHC.Types.Name (getSrcSpan, nameOccName, occNameString)+import GHC.Builtin.Names (trueDataConKey, falseDataConKey)+import qualified GHC.Core.TyCon as TyCon+import GHC.Builtin.Types (tupleTyCon)+import GHC.Types.Unique (getKey)+#else+import BasicTypes (Boxity (..))+import Name (getSrcSpan, nameOccName, occNameString)+import PrelNames (trueDataConKey, falseDataConKey)+import qualified TyCon+import TysWiredIn (tupleTyCon)+import Unique (getKey)+#endif++import Clash.Class.BitPack (pack,unpack)+import Clash.Core.DataCon (DataCon (..))+import Clash.Core.Evaluator.Types+import Clash.Core.Literal (Literal (..))+import Clash.Core.Name+ (Name (..), NameSort (..), mkUnsafeSystemName)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Term+ (IsMultiPrim (..), Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps)+import Clash.Core.TermInfo (piResultTys, applyTypeToArgs)+import Clash.Core.Type+ (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,+ splitFunForallTy, tyView)+import Clash.Core.TyCon+ (TyConMap, TyConName, tyConDataCons)+import Clash.Core.TysPrim+import Clash.Core.Util+ (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo,+ undefinedTm)+import Clash.Core.Var (mkLocalId, mkTyVar)+import Clash.Debug+import Clash.GHC.GHC2Core (modNameM)+import Clash.Rewrite.Util (mkSelectorCase)+import Clash.Unique (lookupUniqMap)+import Clash.Util+ (MonadUnique (..), clogBase, flogBase, curLoc)+import Clash.Normalize.PrimitiveReductions+ (typeNatMul, typeNatSub, typeNatAdd, vecLastPrim, vecInitPrim, vecHeadPrim,+ vecTailPrim, mkVecCons, mkVecNil)++import Clash.Promoted.Nat.Unsafe (unsafeSNat)+import qualified Clash.Sized.Internal.BitVector as BitVector+import qualified Clash.Sized.Internal.Signed as Signed+import qualified Clash.Sized.Internal.Unsigned as Unsigned+import Clash.Sized.Internal.BitVector(BitVector(..), Bit(..))+import Clash.Sized.Internal.Signed (Signed (..))+import Clash.Sized.Internal.Unsigned (Unsigned (..))+import Clash.XException (isX)++import {-# SOURCE #-} Clash.GHC.Evaluator++isUndefinedPrimVal :: Value -> Bool+isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) =+ primName `elem` ["Clash.Transformations.undefined"+ ,"Clash.XException.errorX"+ ,"Control.Exception.Base.absentError"]+isUndefinedPrimVal _ = False++-- | Evaluation of primitive operations.+ghcPrimUnwind :: PrimUnwind+ghcPrimUnwind tcm p tys vs v [] m+ | primName p `elem` [ "Clash.Sized.Internal.Index.fromInteger#"+ , "GHC.CString.unpackCString#"+ , "Clash.Transformations.removedArg"+ , "GHC.Prim.MutableByteArray#"+ , "Clash.Transformations.undefined"+ ]+ -- The above primitives are actually values, and not operations.+ = ghcUnwind (PrimVal p tys (vs ++ [v])) m tcm+ | primName p == "Clash.Sized.Internal.BitVector.fromInteger#"+ = case (vs,v) of+ ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), mask, Lit (IntegerLiteral (wrapUnsigned n i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"+ = case (vs,v) of+ ([mask], integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [mask, Lit (IntegerLiteral (wrapUnsigned 1 i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | primName p == "Clash.Sized.Internal.Signed.fromInteger#"+ = case (vs,v) of+ ([naturalLiteral -> Just n],integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapSigned n i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"+ = case (vs,v) of+ ([naturalLiteral -> Just n],integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapUnsigned n i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | isUndefinedPrimVal v+ = let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v])+ in Just $ flip setTerm m $ undefinedTm $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ | otherwise+ = ghcPrimStep tcm (forcePrims m) p tys (vs ++ [v]) m++ghcPrimUnwind tcm p tys vs v [e] m0+ -- Primitives are usually considered undefined when one of their arguments is+ -- (unless they're unused). _Some_ primitives can still yield a result even+ -- though one of their arguments is undefined. It turns out that all primitives+ -- exhibiting this property happen to be "lazy" in their last argument. Thus,+ -- all the cases can be covered by a match on [e] and their names:+ | primName p `elem` [ "Clash.Sized.Vector.lazyV"+ , "Clash.Sized.Vector.replicate"+ , "Clash.Sized.Vector.replace_int"+ , "GHC.Classes.&&"+ , "GHC.Classes.||"+ ]+ = if isUndefinedPrimVal v then+ let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ [Left e]+ in Just $ flip setTerm m0 $ undefinedTm $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ else+ let (m1,i) = newLetBinding tcm m0 e+ in ghcPrimStep tcm (forcePrims m0) p tys (vs ++ [v,Suspend (Var i)]) m1++ghcPrimUnwind tcm p tys vs (collectValueTicks -> (v, ts)) (e:es) m+ | isUndefinedPrimVal v+ = let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ map Left (e:es)+ in Just $ flip setTerm m $ undefinedTm $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ | otherwise+ = Just . setTerm e $ stackPush (PrimApply p tys (vs ++ [foldr TickValue v ts]) es) m++newtype PrimEvalMonad a = PEM (State Supply a)+ deriving (Functor, Applicative, Monad, MonadState Supply)++instance MonadUnique PrimEvalMonad where+ getUniqueM = PEM $ State.state (\s -> case freshId s of (!i,!s') -> (i,s'))++runPEM :: PrimEvalMonad a -> Supply -> (a, Supply)+runPEM (PEM m) = State.runState m++ghcPrimStep :: PrimStep+ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of+-----------------+-- GHC.Prim.Char#+-----------------+ "GHC.Prim.gtChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i > j))+ "GHC.Prim.geChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i == j))+ "GHC.Prim.neChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ "GHC.Prim.ltChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i < j))+ "GHC.Prim.leChar#" | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i <= j))+ "GHC.Prim.ord#" | [i] <- charLiterals' args+ -> reduce (integerToIntLiteral (toInteger $ ord i))++----------------+-- GHC.Prim.Int#+----------------+ "GHC.Prim.+#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i+j))+ "GHC.Prim.-#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i-j))+ "GHC.Prim.*#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i*j))++ "GHC.Prim.mulIntMayOflo#" | Just (i,j) <- intLiterals args+ -> let !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ c :: Int#+ c = mulIntMayOflo# a b+ in reduce (integerToIntLiteral (toInteger $ I# c))++ "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals args+ -> reduce $ catchDivByZero (integerToIntLiteral (i `quot` j))+ "GHC.Prim.remInt#" | Just (i,j) <- intLiterals args+ -> reduce $ catchDivByZero (integerToIntLiteral (i `rem` j))+ "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [Left $ catchDivByZero (integerToIntLiteral q)+ ,Left $ catchDivByZero (integerToIntLiteral r)])+ in reduce ret++ "GHC.Prim.andI#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i .&. j))+ "GHC.Prim.orI#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i .|. j))+ "GHC.Prim.xorI#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i `xor` j))+ "GHC.Prim.notI#" | [i] <- intLiterals' args+ -> reduce (integerToIntLiteral (complement i))++ "GHC.Prim.negateInt#"+ | [Lit (IntLiteral i)] <- args+ -> reduce (integerToIntLiteral (negate i))++ "GHC.Prim.addIntC#" | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ !(# d, c #) = addIntC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])+ "GHC.Prim.subIntC#" | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ !(# d, c #) = subIntC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])++ "GHC.Prim.>#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i > j))+ "GHC.Prim.>=#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ "GHC.Prim.==#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i == j))+ "GHC.Prim./=#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ "GHC.Prim.<#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i < j))+ "GHC.Prim.<=#" | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ "GHC.Prim.chr#" | [i] <- intLiterals' args+ -> reduce (charToCharLiteral (chr $ fromInteger i))++ "GHC.Prim.int2Word#"+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behavior++ "GHC.Prim.int2Float#"+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)+ "GHC.Prim.int2Double#"+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)++ "GHC.Prim.word2Float#"+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)+ "GHC.Prim.word2Double#"+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)++ "GHC.Prim.uncheckedIShiftL#"+ | [ Lit (IntLiteral i)+ , Lit (IntLiteral s)+ ] <- args+ -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))+ "GHC.Prim.uncheckedIShiftRA#"+ | [ Lit (IntLiteral i)+ , Lit (IntLiteral s)+ ] <- args+ -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))+ "GHC.Prim.uncheckedIShiftRL#" | Just (i,j) <- intLiterals args+ -> let !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ c :: Int#+ c = uncheckedIShiftRL# a b+ in reduce (integerToIntLiteral (toInteger $ I# c))++-----------------+-- GHC.Prim.Word#+-----------------+ "GHC.Prim.plusWord#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i+j))++ "GHC.Prim.subWordC#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# d, c #) = subWordC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])++ "GHC.Prim.plusWord2#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# h', l #) = plusWord2# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# h')+ , Left (Literal . WordLiteral . toInteger $ W# l)])++ "GHC.Prim.minusWord#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i-j))+ "GHC.Prim.timesWord#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i*j))++ "GHC.Prim.timesWord2#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# h', l #) = timesWord2# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# h')+ , Left (Literal . WordLiteral . toInteger $ W# l)])++ "GHC.Prim.quotWord#" | Just (i,j) <- wordLiterals args+ -> reduce $ catchDivByZero (integerToWordLiteral (i `quot` j))+ "GHC.Prim.remWord#" | Just (i,j) <- wordLiterals args+ -> reduce $ catchDivByZero (integerToWordLiteral (i `rem` j))+ "GHC.Prim.quotRemWord#" | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [Left $ catchDivByZero (integerToWordLiteral q)+ ,Left $ catchDivByZero (integerToWordLiteral r)])+ in reduce ret+ "GHC.Prim.quotRemWord2#" | [i,j,k'] <- wordLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(W# c) = fromInteger k'+ !(# x, y #) = quotRemWord2# a b c+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# x)+ , Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# y)])++ "GHC.Prim.and#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i .&. j))+ "GHC.Prim.or#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i .|. j))+ "GHC.Prim.xor#" | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i `xor` j))+ "GHC.Prim.not#" | [i] <- wordLiterals' args+ -> reduce (integerToWordLiteral (complement i))++ "GHC.Prim.uncheckedShiftL#"+ | [ Lit (WordLiteral w)+ , Lit (IntLiteral i)+ ] <- args+ -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))+ "GHC.Prim.uncheckedShiftRL#"+ | [ Lit (WordLiteral w)+ , Lit (IntLiteral i)+ ] <- args+ -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))++ "GHC.Prim.word2Int#"+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behavior++ "GHC.Prim.gtWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i > j))+ "GHC.Prim.geWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i == j))+ "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ "GHC.Prim.ltWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i < j))+ "GHC.Prim.leWord#" | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ "GHC.Prim.popCnt8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i+ "GHC.Prim.popCnt16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i+ "GHC.Prim.popCnt32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i+ "GHC.Prim.popCnt64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i+ "GHC.Prim.popCnt#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i++ "GHC.Prim.clz8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i+ "GHC.Prim.clz16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i+ "GHC.Prim.clz32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i+ "GHC.Prim.clz64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i+ "GHC.Prim.clz#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i++ "GHC.Prim.ctz8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)+ "GHC.Prim.ctz16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)+ "GHC.Prim.ctz32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)+ "GHC.Prim.ctz64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)+ "GHC.Prim.ctz#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i++ "GHC.Prim.byteSwap16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i+ "GHC.Prim.byteSwap32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i+ "GHC.Prim.byteSwap64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i+ "GHC.Prim.byteSwap#" | [i] <- wordLiterals' args -- assume 64bits+ -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i++#if MIN_VERSION_base(4,14,0)+ "GHC.Prim.bitReverse#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i -- assume 64bits+ "GHC.Prim.bitReverse8#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse8 . fromInteger $ i+ "GHC.Prim.bitReverse16#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse16 . fromInteger $ i+ "GHC.Prim.bitReverse32#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse32 . fromInteger $ i+ "GHC.Prim.bitReverse64#" | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i+#endif+------------+-- Narrowing+------------+ "GHC.Prim.narrow8Int#" | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow8Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ "GHC.Prim.narrow16Int#" | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow16Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ "GHC.Prim.narrow32Int#" | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow32Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ "GHC.Prim.narrow8Word#" | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow8Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b+ "GHC.Prim.narrow16Word#" | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow16Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b+ "GHC.Prim.narrow32Word#" | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow32Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b++----------+-- Double#+----------+ "GHC.Prim.>##" | Just r <- liftDDI (>##) args+ -> reduce r+ "GHC.Prim.>=##" | Just r <- liftDDI (>=##) args+ -> reduce r+ "GHC.Prim.==##" | Just r <- liftDDI (==##) args+ -> reduce r+ "GHC.Prim./=##" | Just r <- liftDDI (/=##) args+ -> reduce r+ "GHC.Prim.<##" | Just r <- liftDDI (<##) args+ -> reduce r+ "GHC.Prim.<=##" | Just r <- liftDDI (<=##) args+ -> reduce r+ "GHC.Prim.+##" | Just r <- liftDDD (+##) args+ -> reduce r+ "GHC.Prim.-##" | Just r <- liftDDD (-##) args+ -> reduce r+ "GHC.Prim.*##" | Just r <- liftDDD (*##) args+ -> reduce r+ "GHC.Prim./##" | Just r <- liftDDD (/##) args+ -> reduce r++ "GHC.Prim.negateDouble#" | Just r <- liftDD negateDouble# args+ -> reduce r+ "GHC.Prim.fabsDouble#" | Just r <- liftDD fabsDouble# args+ -> reduce r++ "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args+ -> let !(D# a) = fromRational i+ r = double2Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# r+ "GHC.Prim.double2Float#"+ | [Lit (DoubleLiteral d)] <- args+ -> reduce (Literal (FloatLiteral (toRational (fromRational d :: Float))))+++ "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args+ -> reduce r+ "GHC.Prim.logDouble#" | Just r <- liftDD logDouble# args+ -> reduce r+ "GHC.Prim.sqrtDouble#" | Just r <- liftDD sqrtDouble# args+ -> reduce r+ "GHC.Prim.sinDouble#" | Just r <- liftDD sinDouble# args+ -> reduce r+ "GHC.Prim.cosDouble#" | Just r <- liftDD cosDouble# args+ -> reduce r+ "GHC.Prim.tanDouble#" | Just r <- liftDD tanDouble# args+ -> reduce r+ "GHC.Prim.asinDouble#" | Just r <- liftDD asinDouble# args+ -> reduce r+ "GHC.Prim.acosDouble#" | Just r <- liftDD acosDouble# args+ -> reduce r+ "GHC.Prim.atanDouble#" | Just r <- liftDD atanDouble# args+ -> reduce r+ "GHC.Prim.sinhDouble#" | Just r <- liftDD sinhDouble# args+ -> reduce r+ "GHC.Prim.coshDouble#" | Just r <- liftDD coshDouble# args+ -> reduce r+ "GHC.Prim.tanhDouble#" | Just r <- liftDD tanhDouble# args+ -> reduce r++#if MIN_VERSION_ghc(8,7,0)+ "GHC.Prim.asinhDouble#" | Just r <- liftDD asinhDouble# args+ -> reduce r+ "GHC.Prim.acoshDouble#" | Just r <- liftDD acoshDouble# args+ -> reduce r+ "GHC.Prim.atanhDouble#" | Just r <- liftDD atanhDouble# args+ -> reduce r+#endif++ "GHC.Prim.**##" | Just r <- liftDDD (**##) args+ -> reduce r+-- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)+ "GHC.Prim.decodeDouble_2Int#" | [i] <- doubleLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = fromRational i+ !(# p, q, r, s #) = decodeDouble_2Int# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# p)+ , Left (Literal . WordLiteral . toInteger $ W# q)+ , Left (Literal . WordLiteral . toInteger $ W# r)+ , Left (Literal . IntLiteral . toInteger $ I# s)])+-- decodeDouble_Int64# :: Double# -> (# Int64#, Int# #)+ "GHC.Prim.decodeDouble_Int64#" | [i] <- doubleLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = fromRational i+ !(# p, q #) = decodeDouble_Int64# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I64# p)+ , Left (Literal . IntLiteral . toInteger $ I# q)])++--------+-- Float+--------+ "GHC.Prim.gtFloat#" | Just r <- liftFFI gtFloat# args+ -> reduce r+ "GHC.Prim.geFloat#" | Just r <- liftFFI geFloat# args+ -> reduce r+ "GHC.Prim.eqFloat#" | Just r <- liftFFI eqFloat# args+ -> reduce r+ "GHC.Prim.neFloat#" | Just r <- liftFFI neFloat# args+ -> reduce r+ "GHC.Prim.ltFloat#" | Just r <- liftFFI ltFloat# args+ -> reduce r+ "GHC.Prim.leFloat#" | Just r <- liftFFI leFloat# args+ -> reduce r++ "GHC.Prim.plusFloat#" | Just r <- liftFFF plusFloat# args+ -> reduce r+ "GHC.Prim.minusFloat#" | Just r <- liftFFF minusFloat# args+ -> reduce r+ "GHC.Prim.timesFloat#" | Just r <- liftFFF timesFloat# args+ -> reduce r+ "GHC.Prim.divideFloat#" | Just r <- liftFFF divideFloat# args+ -> reduce r++ "GHC.Prim.negateFloat#" | Just r <- liftFF negateFloat# args+ -> reduce r+ "GHC.Prim.fabsFloat#" | Just r <- liftFF fabsFloat# args+ -> reduce r++ "GHC.Prim.float2Int#" | [i] <- floatLiterals' args+ -> let !(F# a) = fromRational i+ r = float2Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# r++ "GHC.Prim.expFloat#" | Just r <- liftFF expFloat# args+ -> reduce r+ "GHC.Prim.logFloat#" | Just r <- liftFF logFloat# args+ -> reduce r+ "GHC.Prim.sqrtFloat#" | Just r <- liftFF sqrtFloat# args+ -> reduce r+ "GHC.Prim.sinFloat#" | Just r <- liftFF sinFloat# args+ -> reduce r+ "GHC.Prim.cosFloat#" | Just r <- liftFF cosFloat# args+ -> reduce r+ "GHC.Prim.tanFloat#" | Just r <- liftFF tanFloat# args+ -> reduce r+ "GHC.Prim.asinFloat#" | Just r <- liftFF asinFloat# args+ -> reduce r+ "GHC.Prim.acosFloat#" | Just r <- liftFF acosFloat# args+ -> reduce r+ "GHC.Prim.atanFloat#" | Just r <- liftFF atanFloat# args+ -> reduce r+ "GHC.Prim.sinhFloat#" | Just r <- liftFF sinhFloat# args+ -> reduce r+ "GHC.Prim.coshFloat#" | Just r <- liftFF coshFloat# args+ -> reduce r+ "GHC.Prim.tanhFloat#" | Just r <- liftFF tanhFloat# args+ -> reduce r+ "GHC.Prim.powerFloat#" | Just r <- liftFFF powerFloat# args+ -> reduce r++#if MIN_VERSION_base(4,12,0)+ -- GHC.Float.asinh -- XXX: Very fragile+ -- $w$casinh is the Double specialisation of asinh+ -- $w$casinh1 is the Float specialisation of asinh+ "GHC.Float.$w$casinh" | Just r <- liftDD go args+ -> reduce r+ where go f = case asinh (D# f) of+ D# f' -> f'+ "GHC.Float.$w$casinh1" | Just r <- liftFF go args+ -> reduce r+ where go f = case asinh (F# f) of+ F# f' -> f'+#endif++#if MIN_VERSION_ghc(8,7,0)+ "GHC.Prim.asinhFloat#" | Just r <- liftFF asinhFloat# args+ -> reduce r+ "GHC.Prim.acoshFloat#" | Just r <- liftFF acoshFloat# args+ -> reduce r+ "GHC.Prim.atanhFloat#" | Just r <- liftFF atanhFloat# args+ -> reduce r+#endif++ "GHC.Prim.float2Double#" | [i] <- floatLiterals' args+ -> let !(F# a) = fromRational i+ r = float2Double# a+ in reduce . Literal . DoubleLiteral . toRational $ D# r+++ "GHC.Prim.newByteArray#"+ | [iV,PrimVal rwTy _ _] <- args+ , [i] <- intLiterals' [iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ p = primCount mach+ lit = Literal (ByteArrayLiteral (fromList (List.genericReplicate i 0)))+ mbaTy = mkFunTy intPrimTy (last tyArgs)+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left (mkApps (Prim (PrimInfo "GHC.Prim.MutableByteArray#" mbaTy WorkNever SingleResult))+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just . setTerm newE $ primInsert p lit mach++ "GHC.Prim.setByteArray#"+ | [PrimVal _mbaTy _ [baV]+ ,offV,lenV,cV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]+ -> let Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# off') = fromInteger off+ !(I# len') = fromInteger len+ !(I# c') = fromInteger c+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ svoid (setByteArray# mba off' len' c')+ BA.unsafeFreezeByteArray (BA.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach++ "GHC.Prim.writeWordArray#"+ | [PrimVal _mbaTy _ [baV]+ ,iV,wV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ , [w] <- wordLiterals' [wV]+ -> let Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# i') = fromInteger i+ !(W# w') = fromIntegral w+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ svoid (writeWordArray# mba i' w')+ BA.unsafeFreezeByteArray (BA.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach++ "GHC.Prim.unsafeFreezeByteArray#"+ | [PrimVal _mbaTy _ [baV]+ ,PrimVal rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Just ba' = primLookup (fromInteger ba) mach+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left ba'])++ "GHC.Prim.sizeofByteArray#"+ | [Lit (ByteArrayLiteral ba)] <- args+ -> reduce (Literal (IntLiteral (toInteger (BA.sizeofByteArray ba))))++ "GHC.Prim.indexWordArray#"+ | [Lit (ByteArrayLiteral (BA.ByteArray ba)),iV] <- args+ , [i] <- intLiterals' [iV]+ -> let !(I# i') = fromInteger i+ !w = indexWordArray# ba i'+ in reduce (Literal (WordLiteral (toInteger (W# w))))++ "GHC.Prim.getSizeofMutBigNat#"+ | [PrimVal _mbaTy _ [baV]+ ,PrimVal rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Just (Literal (ByteArrayLiteral ba')) = primLookup (fromInteger ba) mach+ lit = Literal (IntLiteral (toInteger (BA.sizeofByteArray ba')))+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left lit])++ "GHC.Prim.resizeMutableByteArray#"+ | [PrimVal mbaTy _ [baV]+ ,iV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ p = primCount mach+ Just (Literal (ByteArrayLiteral ba1))+ = primLookup (fromInteger ba) mach+ !(I# i') = fromInteger i+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of+ (# s', mba' #) -> (# s', BA.MutableByteArray mba' #))+ BA.unsafeFreezeByteArray mba'+ ba3 = Literal (ByteArrayLiteral ba2)+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left (mkApps (Prim mbaTy)+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just . setTerm newE $ primInsert p ba3 mach++ "GHC.Prim.shrinkMutableByteArray#"+ | [PrimVal _mbaTy _ [baV]+ ,lenV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,len] <- intLiterals' [baV,lenV]+ -> let Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# len') = fromInteger len+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ svoid (shrinkMutableByteArray# mba len')+ BA.unsafeFreezeByteArray (BA.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach++ "GHC.Prim.copyByteArray#"+ | [Lit (ByteArrayLiteral (BA.ByteArray src_ba))+ ,src_offV+ ,PrimVal _mbaTy _ [dst_mbaV]+ ,dst_offV, nV+ ,PrimVal rwTy _ _+ ] <- args+ , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]+ -> let Just (Literal (ByteArrayLiteral dst_ba)) =+ primLookup (fromInteger dst_mba) mach+ !(I# src_off') = fromInteger src_off+ !(I# dst_off') = fromInteger dst_off+ !(I# n') = fromInteger n+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray dst_mba1 <- BA.unsafeThawByteArray dst_ba+ svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')+ BA.unsafeFreezeByteArray (BA.MutableByteArray dst_mba1)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach++ "GHC.Prim.readWordArray#"+ | [PrimVal _mbaTy _ [baV]+ ,offV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,off] <- intLiterals' [baV,offV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# off') = fromInteger off+ w = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ IO (\s -> case readWordArray# mba off' s of+ (# s', w' #) -> (# s', W# w' #))+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left (Literal (WordLiteral (toInteger w)))+ ])+ in reduce newE++-- decodeFloat_Int# :: Float# -> (#Int#, Int##)+ "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(F# a) = fromRational i+ !(# p, q #) = decodeFloat_Int# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# p)+ , Left (Literal . IntLiteral . toInteger $ I# q)])++ "GHC.Prim.tagToEnum#"+ | [ConstTy (TyCon tcN)] <- tys+ , [Lit (IntLiteral i)] <- args+ -> let dc = do { tc <- lookupUniqMap tcN tcm+ ; let dcs = tyConDataCons tc+ ; List.find ((== (i+1)) . toInteger . dcTag) dcs+ }+ in (\e -> setTerm (Data e) mach) <$> dc++ "GHC.Classes.eqInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++ "GHC.Classes.neInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++ "GHC.Classes.leInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++ "GHC.Classes.ltInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))++ "GHC.Classes.geInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))++ "GHC.Classes.gtInt" | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))++ "GHC.Classes.&&"+ | [ lArg , rArg ] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ -- evaluation of the arguments is deferred until the evaluation of the ghcPrimUnwindWith+ -- to make `&&` lazy in both arguments+ , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf eval tcm True (setTerm (valToTerm lArg) $ stackClear mach)+ , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf eval tcm True (setTerm (valToTerm rArg) $ stackClear mach1)+ -> case [ lArgWHNF, rArgWHNF ] of+ [ Data lCon, Data rCon ] ->+ Just $ mach2+ { mStack = mStack mach+ , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon && isTrueDC rCon)+ }++ [ Data lCon, _ ]+ | isTrueDC lCon -> reduce rArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty False)++ [ _, Data rCon ]+ | isTrueDC rCon -> reduce lArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty False)++ _ -> Nothing++ "GHC.Classes.||"+ | [ lArg , rArg ] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ -- evaluation of the arguments is deferred until the evaluation of the ghcPrimUnwindWith+ -- to make `||` lazy in both arguments+ , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf eval tcm True (setTerm (valToTerm lArg) $ stackClear mach)+ , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf eval tcm True (setTerm (valToTerm rArg) $ stackClear mach1)+ -> case [ lArgWHNF, rArgWHNF ] of+ [ Data lCon, Data rCon ] ->+ Just $ mach2+ { mStack = mStack mach+ , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon || isTrueDC rCon)+ }++ [ Data lCon, _ ]+ | isFalseDC lCon -> reduce rArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty True)++ [ _, Data rCon ]+ | isFalseDC rCon -> reduce lArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty True)++ _ -> Nothing++ "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i `div` j))++ -- modInt# :: Int# -> Int# -> Int#+ "GHC.Classes.modInt#"+ | [dividend, divisor] <- intLiterals' args+ ->+ if divisor == 0 then+ let iTy = snd (splitFunForallTy ty) in+ reduce (undefinedTm iTy)+ else+ reduce (Literal (IntLiteral (dividend `mod` divisor)))++ "GHC.Classes.not"+ | [DC bCon _] <- args+ -> reduce (boolToBoolLiteral tcm ty (nameOcc (dcName bCon) == "GHC.Types.False"))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerLogBase#"+ | Just (a,b) <- integerLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . WordLiteral . toInteger) c++ "GHC.Num.Natural.naturalLogBase#"+ | Just (a,b) <- naturalLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . WordLiteral . toInteger) c+#else+ "GHC.Integer.Logarithms.integerLogBase#"+ | Just (a,b) <- integerLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . IntLiteral . toInteger) c+#endif++#if !MIN_VERSION_base(4,15,0)+ "GHC.Integer.Type.smallInteger"+ | [Lit (IntLiteral i)] <- args+ -> reduce (Literal (IntegerLiteral i))+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerToInt#"+#else+ "GHC.Integer.Type.integerToInt"+#endif+ | [i] <- integerLiterals' args+ -> reduce (integerToIntLiteral i)++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerDecodeDouble#" -- :: Double# -> (#Integer, Int##)+#else+ "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)+#endif+ | [Lit (DoubleLiteral i)] <- args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = fromRational i+ !(# b, c #) = decodeDoubleInteger a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (integerToIntegerLiteral b)+ , Left (integerToIntLiteral . toInteger $ I# c)])++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerEncodeDouble#" -- :: Integer -> Int# -> Double+#else+ "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double+#endif+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> let !(I# k') = fromInteger j+ r = encodeDoubleInteger i k'+ in reduce . Literal . DoubleLiteral . toRational $ D# r++#if MIN_VERSION_base(4,15,0)+ "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 . toRational $ F# r+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerQuotRem#" -- :: Integer -> Integer -> (#Integer, Integer#)+#else+ "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)+#endif+ | [i, j] <- integerLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (integerToIntegerLiteral q)+ , Left $ catchDivByZero (integerToIntegerLiteral r)])++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerAdd"+#else+ "GHC.Integer.Type.plusInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i+j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerSub"+#else+ "GHC.Integer.Type.minusInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i-j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerMul"+#else+ "GHC.Integer.Type.timesInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i*j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerNegate"+#else+ "GHC.Integer.Type.negateInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (integerToIntegerLiteral (negate i))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerDiv"+#else+ "GHC.Integer.Type.divInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `div` j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerMod"+#else+ "GHC.Integer.Type.modInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `mod` j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerQuot"+#else+ "GHC.Integer.Type.quotInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `quot` j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerRem"+#else+ "GHC.Integer.Type.remInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `rem` j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerDivMod#"+#else+ "GHC.Integer.Type.divModInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty+ (Just ubTupTc) = lookupUniqMap ubTupTcNm tcm+ [ubTupDc] = tyConDataCons ubTupTc+ (d,m) = divMod i j+ in reduce $+ mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi+ , Right intTy, Right intTy+ , Left $ catchDivByZero (Literal (IntegerLiteral d))+ , Left $ catchDivByZero (Literal (IntegerLiteral m))+ ]++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerGt"+#else+ "GHC.Integer.Type.gtInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerGe"+#else+ "GHC.Integer.Type.geInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerEq"+#else+ "GHC.Integer.Type.eqInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerNe"+#else+ "GHC.Integer.Type.neqInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerLt"+#else+ "GHC.Integer.Type.ltInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerLe"+#else+ "GHC.Integer.Type.leInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerGt#"+#else+ "GHC.Integer.Type.gtInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i > j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerGe#"+#else+ "GHC.Integer.Type.geInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i >= j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerEq#"+#else+ "GHC.Integer.Type.eqInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i == j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerNe#"+#else+ "GHC.Integer.Type.neqInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i /= j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerLt#"+#else+ "GHC.Integer.Type.ltInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i < j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerLe#"+#else+ "GHC.Integer.Type.leInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i <= j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerCompare"+#else+ "GHC.Integer.Type.compareInteger" -- :: Integer -> Integer -> Ordering+#endif+ | [i, j] <- integerLiterals' args+ -> let -- Get the required result type (viewed as an applied type constructor name)+ (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty+ -- Find the type constructor from the name+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ -- Get the data constructors of that type+ -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'+ [ltDc, eqDc, gtDc] = tyConDataCons tupTc+ -- Do the actual compile-time evaluation+ ordVal = compareInteger i j+ in reduce $ case ordVal of+ LT -> Data ltDc+ EQ -> Data eqDc+ GT -> Data gtDc++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerShiftR#"+ | [iV, Lit (WordLiteral j)] <- args+#else+ "GHC.Integer.Type.shiftRInteger"+ | [iV, Lit (IntLiteral j)] <- args+#endif+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerShiftL#"+ | [iV, Lit (WordLiteral j)] <- args+#else+ "GHC.Integer.Type.shiftLInteger"+ | [iV, Lit (IntLiteral j)] <- args+#endif+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerFromWord#"+#else+ "GHC.Integer.Type.wordToInteger"+#endif+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (IntegerLiteral w))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerToWord#"+#else+ "GHC.Integer.Type.integerToWord"+#endif+ | [i] <- integerLiterals' args+ -> reduce (integerToWordLiteral i)++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerTestBit#" -- :: Integer -> Int# -> Int#+ | [Lit (IntegerLiteral i), Lit (WordLiteral j)] <- args+ -> reduce (boolToIntLiteral (testBit i (fromInteger j)))+#else+ "GHC.Integer.Type.testBitInteger" -- :: Integer -> Int# -> Bool+ | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ -> reduce (boolToBoolLiteral tcm ty (testBit i (fromInteger j)))+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.NS"+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (NaturalLiteral w))+ "GHC.Num.Natural.NB"+ | [Lit l] <- args+ -> error ("NB: " <> show l)+ "GHC.Num.Integer.IS"+ | [Lit (IntLiteral i)] <- args+ -> reduce (Literal (IntegerLiteral i))+ "GHC.Num.Integer.IP"+ | [Lit l] <- args+ -> error ("IP: " <> show l)+ "GHC.Num.Integer.IN"+ | [Lit l] <- args+ -> error ("IN: " <> show l)+#else+ "GHC.Natural.NatS#"+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (NaturalLiteral w))+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerFromNatural"+#else+ "GHC.Natural.naturalToInteger"+#endif+ | [i] <- naturalLiterals' args+ -> reduce (Literal (IntegerLiteral (toInteger i)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerToNatural"+#else+ "GHC.Natural.naturalFromInteger"+#endif+ | [i] <- integerLiterals' args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy i id)++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerToNaturalClamp"+ | [i] <- integerLiterals' args+ -> if i < 0 then+ reduce (naturalToNaturalLiteral 0)+ else+ reduce (naturalToNaturalLiteral (fromInteger i))++ "GHC.Num.Integer.integerToNaturalThrow"+ | [i] <- integerLiterals' args+ -> let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy i id)+#endif++#if !MIN_VERSION_base(4,15,0)+ -- GHC.shiftLNatural --- XXX: Fragile worker of GHC.shiflLNatural+ "GHC.Natural.$wshiftLNatural"+ | [nV,iV] <- args+ , [n] <- naturalLiterals' [nV]+ , [i] <- fromInteger <$> intLiterals' [iV]+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy n ((flip shiftL) i))+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalAdd"+#else+ "GHC.Natural.plusNatural"+#endif+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j (+))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalMul"+#else+ "GHC.Natural.timesNatural"+#endif+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j (*))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalSubUnsafe"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ naturalToNaturalLiteral (naturalSubUnsafe i' j')))++ "GHC.Num.Natural.naturalSubThrow"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ case minusNaturalMaybe i' j' of+ Nothing -> checkNaturalRange1 nTy (-1) id+ Just n -> naturalToNaturalLiteral n))+#else+ "GHC.Natural.minusNatural"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ case minusNaturalMaybe i' j' of+ Nothing -> checkNaturalRange1 nTy (-1) id+ Just n -> naturalToNaturalLiteral n))+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalFromWord#"+#else+ "GHC.Natural.wordToNatural#"+#endif+ | [Lit (WordLiteral w)] <- args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy w id)++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalToWord#"+ | [i] <- naturalLiterals' args+ -> reduce (integerToWordLiteral i)++ "GHC.Num.Natural.naturalQuot"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j quot)++ "GHC.Num.Natural.naturalRem"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j rem)+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalQuotRem#" -- :: Natural -> Natural -> (#Natural, Natural#)+ | [i, j] <- naturalLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem (fromInteger i) (fromInteger j)+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (naturalToNaturalLiteral q)+ , Left $ catchDivByZero (naturalToNaturalLiteral r)])+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalGcd"+#else+ "GHC.Natural.gcdNatural"+#endif+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j gcd)++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalLcm"+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j lcm)+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Natural.naturalGt#"+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i > j))++ "GHC.Num.Natural.naturalGe#"+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i >= j))++ "GHC.Num.Natural.naturalEq#"+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i == j))++ "GHC.Num.Natural.naturalNe#"+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i /= j))++ "GHC.Num.Natural.naturalLt#"+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i < j))++ "GHC.Num.Natural.naturalLe#"+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ "GHC.Num.Natural.naturalShiftL#"+ | [iV, Lit (WordLiteral j)] <- args+ , [i] <- naturalLiterals' [iV]+ -> reduce (naturalToNaturalLiteral (fromInteger (i `shiftL` fromInteger j)))++ "GHC.Num.Natural.naturalShiftR#"+ | [iV, Lit (WordLiteral j)] <- args+ , [i] <- naturalLiterals' [iV]+ -> reduce (naturalToNaturalLiteral (fromInteger (i `shiftR` fromInteger j)))++ "GHC.Num.Natural.naturalCompare"+ | [i, j] <- naturalLiterals' args+ -> let -- Get the required result type (viewed as an applied type constructor name)+ (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty+ -- Find the type constructor from the name+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ -- Get the data constructors of that type+ -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'+ [ltDc, eqDc, gtDc] = tyConDataCons tupTc+ -- Do the actual compile-time evaluation+ ordVal = compareInteger i j+ in reduce $ case ordVal of+ LT -> Data ltDc+ EQ -> Data eqDc+ GT -> Data gtDc++ "GHC.Num.Natural.naturalSignum"+ | [i] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (signum i)))++ "GHC.Num.Natural.$wnaturalSignum"+ | [i] <- naturalLiterals' args+ -> reduce (Literal (WordLiteral (signum i)))+#endif++ -- GHC.Real.^ -- XXX: Very fragile+ -- ^_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)+ "GHC.Real.$wf" -- :: Integer -> Int# -> Integer+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral $ i ^ j)+ "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#+ | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args+ -> reduce (integerToIntLiteral $ i ^ j)++ -- Type level ^ -- XXX: Very fragile+ -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.+ "Data.Singletons.TypeLits.Internal.$s^_f" -- ghc-8.4.4, singletons-2.4.1+ | [i,j] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (i ^ j)))+ "Data.Singletons.TypeLits.Internal.$fSingI->^@#@$_f" -- ghc-8.6.5, singletons-2.5.1+ | [i,j] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (i ^ j)))+ "Data.Singletons.TypeLits.Internal.%^_f" -- ghc-8.8.1, singletons-2.6+ | [i,j] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (i ^ j)))++ "GHC.TypeLits.natVal"+ | [Lit (NaturalLiteral n), _] <- args+ -> reduce (integerToIntegerLiteral n)++ "GHC.TypeNats.natVal"+ | [Lit (NaturalLiteral n), _] <- args+ -> reduce (Literal (NaturalLiteral n))++ "GHC.Types.C#"+ | isSubj+ , [Lit (CharLiteral c)] <- args+ -> let (_,tyView -> TyConApp charTcNm []) = splitFunForallTy ty+ (Just charTc) = lookupUniqMap charTcNm tcm+ [charDc] = tyConDataCons charTc+ in reduce (mkApps (Data charDc) [Left (Literal (CharLiteral c))])++ "GHC.Types.I#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I8#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I16#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I32#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+ "GHC.Int.I64#"+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])++ "GHC.Types.W#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W8#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W16#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W32#"+ | isSubj+ , [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+ "GHC.Word.W64#"+ | [Lit (WordLiteral c)] <- args+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])++ "GHC.Float.$w$sfromRat''" -- XXX: Very fragile+ | [Lit (IntLiteral _minEx)+ ,Lit (IntLiteral matDigs)+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV]+ -> case fromInteger matDigs of+ matDigs'+ | matDigs' == floatDigits (undefined :: Float)+ -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+ | matDigs' == floatDigits (undefined :: Double)+ -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++ "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile+ | [Lit (IntLiteral _minEx)+ ,Lit (IntLiteral matDigs)+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV]+ -> case fromInteger matDigs of+ matDigs'+ | matDigs' == floatDigits (undefined :: Float)+ -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+ | matDigs' == floatDigits (undefined :: Double)+ -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerSignum#"+#else+ "GHC.Integer.Type.$wsignumInteger" -- XXX: Not super-fragile, but still..+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntLiteral (signum i)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerSignum"+#else+ "GHC.Integer.Type.signumInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (signumInteger i)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.$wintegerSignum"+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntLiteral (signum i)))+#endif++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerAbs"+#else+ "GHC.Integer.Type.absInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (absInteger i)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerBit#"+ | [i] <- wordLiterals' args+#else+ "GHC.Integer.Type.bitInteger"+ | [i] <- intLiterals' args+#endif+ -> reduce (Literal (IntegerLiteral (bit (fromInteger i))))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerComplement"+#else+ "GHC.Integer.Type.complementInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (complementInteger i)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerOr"+#else+ "GHC.Integer.Type.orInteger"+#endif+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (orInteger i j)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerXor"+#else+ "GHC.Integer.Type.xorInteger"+#endif+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (xorInteger i j)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerAnd"+#else+ "GHC.Integer.Type.andInteger"+#endif+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (andInteger i j)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.integerToDouble#"+#else+ "GHC.Integer.Type.doubleFromInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))++ "GHC.Base.eqString"+ | [PrimVal _ _ [Lit (StringLiteral s1)]+ ,PrimVal _ _ [Lit (StringLiteral s2)]+ ] <- args+ -> reduce (boolToBoolLiteral tcm ty (s1 == s2))+ | otherwise -> error (show args)+++ "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64+ | [DC _ [Left arg]] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (DoubleLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in Just $ mach2+ { mStack = mStack mach+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Double -> BitVector 64) $ fromRational i)+ }++ "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32+ | [DC _ [Left arg]] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (FloatLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in Just $ mach2+ { mStack = mStack mach+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Float -> BitVector 32) $ fromRational i)+ }++ "Clash.Class.BitPack.unpackFloat#"+ | [i] <- bitVectorLiterals' args+ -> reduce (Literal (FloatLiteral (toRational $ (unpack :: BitVector 32 -> Float) (toBV i))))++ "Clash.Class.BitPack.unpackDouble#"+ | [i] <- bitVectorLiterals' args+ -> reduce (Literal (DoubleLiteral (toRational $ (unpack :: BitVector 64 -> Double) (toBV i))))++ -- expIndex#+ -- :: KnownNat m+ -- => Index m+ -- -> SNat n+ -- -> Index (n^m)+ "Clash.Class.Exp.expIndex#"+ | [b] <- indexLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkIndexLit ty (LitTy (NumTy (km^e))) (km^e) (b^e))++ -- expSigned#+ -- :: KnownNat m+ -- => Signed m+ -- -> SNat n+ -- -> Signed (n*m)+ "Clash.Class.Exp.expSigned#"+ | [b] <- signedLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkSignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))++ -- expUnsigned#+ -- :: KnownNat m+ -- => Unsigned m+ -- -> SNat n+ -- -> Unsigned m+ "Clash.Class.Exp.expUnsigned#"+ | [b] <- unsignedLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkUnsignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))++ "Clash.Promoted.Nat.powSNat"+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ -> let c = case a of+ 2 -> 1 `shiftL` (fromInteger b)+ _ -> a ^ b+ (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c))+ , Left (Literal (NaturalLiteral c))]++ "Clash.Promoted.Nat.flogBaseSNat"+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- flogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++ "Clash.Promoted.Nat.clogBaseSNat"+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- clogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]+ | otherwise+ -> error ("clogBaseSNat: args = " <> show args <> ", tys = " <> show tys)++ "Clash.Promoted.Nat.logBaseSNat"+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- flogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++------------+-- BitVector+------------+-- Constructor+ "Clash.Sized.Internal.BitVector.BV"+ | [Right _] <- map (runExcept . tyNatSize tcm) tys+ , Just (m,i) <- integerLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo m i)++ "Clash.Sized.Internal.BitVector.Bit"+ | Just (m,i) <- integerLiterals args+ -> reduce (mkBitLit ty m i)++-- Initialisation+ "Clash.Sized.Internal.BitVector.size#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])+ "Clash.Sized.Internal.BitVector.maxIndex#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])++-- Construction+ "Clash.Sized.Internal.BitVector.high"+ -> reduce (mkBitLit ty 0 1)+ "Clash.Sized.Internal.BitVector.low"+ -> reduce (mkBitLit ty 0 0)++ "Clash.Sized.Internal.BitVector.undefined#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ mask = bit (fromInteger kn) - 1+ in reduce (mkBitVectorLit' resTyInfo mask 0)++-- Eq+ "Clash.Sized.Internal.BitVector.eq##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.BitVector.neq##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.BitVector.lt##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.BitVector.ge##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.BitVector.gt##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.BitVector.le##" | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bits+ "Clash.Sized.Internal.BitVector.and##"+ | [i,j] <- bitLiterals args+ -> let Bit msk val = BitVector.and## (toBit i) (toBit j)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))+ "Clash.Sized.Internal.BitVector.or##"+ | [i,j] <- bitLiterals args+ -> let Bit msk val = BitVector.or## (toBit i) (toBit j)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))+ "Clash.Sized.Internal.BitVector.xor##"+ | [i,j] <- bitLiterals args+ -> let Bit msk val = BitVector.xor## (toBit i) (toBit j)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))++ "Clash.Sized.Internal.BitVector.complement##"+ | [i] <- bitLiterals args+ -> let Bit msk val = BitVector.complement## (toBit i)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))++-- Pack+ "Clash.Sized.Internal.BitVector.pack#"+ | [(msk,i)] <- bitLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk i)++ "Clash.Sized.Internal.BitVector.unpack#"+ | [(msk,i)] <- bitVectorLiterals' args+ -> reduce (mkBitLit ty msk i)++-- Concatenation+ "Clash.Sized.Internal.BitVector.++#" -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)+ | Just (_,m) <- extractKnownNat tcm tys+ , [(mski,i),(mskj,j)] <- bitVectorLiterals' args+ -> let val = i `shiftL` fromInteger m .|. j+ msk = mski `shiftL` fromInteger m .|. mskj+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk val)++-- Reduction+ "Clash.Sized.Internal.BitVector.reduceAnd#" -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceAnd# u)+ "Clash.Sized.Internal.BitVector.reduceOr#" -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceOr# u)+ "Clash.Sized.Internal.BitVector.reduceXor#" -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceXor# u)+++-- Indexing+ "Clash.Sized.Internal.BitVector.index#" -- :: KnownNat n => BitVector n -> Int -> Bit+ | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let resTy = getResultTy tcm ty tys+ (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitLit resTy msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = (toInteger m, toInteger v)+ where Bit m v = (BitVector.index# u i)+ "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n+ | Just (_, n) <- extractKnownNat tcm tys+ , [ _+ , PrimVal bvP _ [_, Lit (NaturalLiteral mskBv), Lit (IntegerLiteral bv)]+ , valArgs -> Just [Literal (IntLiteral i)]+ , PrimVal bP _ [Lit (WordLiteral mskB), Lit (IntegerLiteral b)]+ ] <- args+ , primName bvP == "Clash.Sized.Internal.BitVector.fromInteger#"+ , primName bP == "Clash.Sized.Internal.BitVector.fromInteger##"+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ (mskVal,val) = reifyNat n (op (BV (fromInteger mskBv) (fromInteger bv))+ (fromInteger i)+ (Bit (fromInteger mskB) (fromInteger b)))+ in reduce (mkBitVectorLit' resTyInfo mskVal val)+ where+ op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> (Integer,Integer)+ -- op bv i b _ = (BitVector.unsafeMask res, BitVector.unsafeToInteger res)+ op bv i b _ = splitBV (BitVector.replaceBit# bv i b)+ "Clash.Sized.Internal.BitVector.setSlice#"+ -- :: SNat (m+1+i) -> BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)+ | mTy : iTy : nTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ , Right iN <- runExcept (tyNatSize tcm iTy)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , [i,j] <- bitVectorLiterals' args+ -> let BV msk val = BitVector.setSlice# (unsafeSNat (m+1+iN)) (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j)+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))+ "Clash.Sized.Internal.BitVector.slice#"+ -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)+ | mTy : _ : nTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , [i] <- bitVectorLiterals' args+ -> let BV msk val = BitVector.slice# (toBV i) (unsafeSNat m) (unsafeSNat n)+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))+ "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)+ | nTy : mTy : _ <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ , [(mski,i)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ bvTy : _ = tyArgs+ valM = i `shiftR` fromInteger n+ mskM = mski `shiftR` fromInteger n+ valN = i .&. mask+ mskN = mski .&. mask+ mask = bit (fromInteger n) - 1+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (mkBitVectorLit bvTy mTy m mskM valM)+ , Left (mkBitVectorLit bvTy nTy n mskN valN)])++ "Clash.Sized.Internal.BitVector.msb#" -- :: forall n. KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy (toInteger msk) (toInteger val))+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Word,Word)+ op u _ = (unsafeMask# res, BitVector.unsafeToInteger# res)+ where+ res = BitVector.msb# u+ "Clash.Sized.Internal.BitVector.lsb#" -- :: BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ -> let resTy = getResultTy tcm ty tys+ Bit msk val = BitVector.lsb# (toBV i)+ in reduce (mkBitLit resTy (toInteger msk) (toInteger val))+++-- Eq+ -- eq#, neq# :: KnownNat n => BitVector n -> BitVector n -> Bool+ "Clash.Sized.Internal.BitVector.eq#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.eq# ty tcm args)+ -> reduce val++ "Clash.Sized.Internal.BitVector.neq#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.neq# ty tcm args)+ -> reduce val++-- Ord+ -- lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool+ "Clash.Sized.Internal.BitVector.lt#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.lt# ty tcm args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.ge#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.ge# ty tcm args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.gt#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.gt# ty tcm args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.le#"+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.le# ty tcm args)+ -> reduce val++-- Bounded+ "Clash.Sized.Internal.BitVector.minBound#"+ | Just (nTy,len) <- extractKnownNat tcm tys+ -> reduce (mkBitVectorLit ty nTy len 0 0)+ "Clash.Sized.Internal.BitVector.maxBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ mb) - 1+ in reduce (mkBitVectorLit ty litTy mb 0 maxB)++-- Num+ "Clash.Sized.Internal.BitVector.+#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.-#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.*#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.negate#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = splitBV (BitVector.negate# u)++-- ExtendingNum+ "Clash.Sized.Internal.BitVector.plus#" -- :: (KnownNat n, KnownNat m) => BitVector m -> BitVector n -> BitVector (Max m n + 1)+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i+j))++ "Clash.Sized.Internal.BitVector.minus#"+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 val)++ "Clash.Sized.Internal.BitVector.times#"+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i*j))++-- Integral+ "Clash.Sized.Internal.BitVector.quot#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.BitVector.rem#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.BitVector.toInteger#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (toBV i))+ in reduce (integerToIntegerLiteral val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = BitVector.toInteger# u++-- Bits+ "Clash.Sized.Internal.BitVector.and#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.and#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.or#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.or#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.BitVector.xor#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.xor#) ty tcm tys args)+ -> reduce val++ "Clash.Sized.Internal.BitVector.complement#"+ | [i] <- bitVectorLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = splitBV $ BitVector.complement# u++ "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)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.shiftL# u i)+ "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)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.shiftR# u i)+ "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)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.rotateL# u i)+ "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)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.rotateR# u i)++-- truncateB+ "Clash.Sized.Internal.BitVector.truncateB#" -- forall a b . KnownNat a => BitVector (a + b) -> BitVector a+ | aTy : _ <- tys+ , Right ka <- runExcept (tyNatSize tcm aTy)+ , [(mski,i)] <- bitVectorLiterals' args+ -> let bitsKeep = (bit (fromInteger ka)) - 1+ val = i .&. bitsKeep+ msk = mski .&. bitsKeep+ in reduce (mkBitVectorLit ty aTy ka msk val)++--------+-- Index+--------+-- BitPack+ "Clash.Sized.Internal.Index.pack#"+ | nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , [i] <- indexLiterals' args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo 0 i)+ "Clash.Sized.Internal.Index.unpack#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [(0,i)] <- bitVectorLiterals' args+ -> reduce (mkIndexLit ty nTy kn i)++-- Eq+ "Clash.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.Index.lt#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.Index.ge#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.Index.gt#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.Index.le#"+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+ "Clash.Sized.Internal.Index.maxBound#"+ | Just (nTy,mb) <- extractKnownNat tcm tys+ -> reduce (mkIndexLit ty nTy mb (mb - 1))++-- Num+ "Clash.Sized.Internal.Index.+#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i + j))+ "Clash.Sized.Internal.Index.-#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i - j))+ "Clash.Sized.Internal.Index.*#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i * j))++-- ExtendingNum+ "Clash.Sized.Internal.Index.plus#"+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i + j))+ "Clash.Sized.Internal.Index.minus#"+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i - j))+ "Clash.Sized.Internal.Index.times#"+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i * j))++-- Integral+ "Clash.Sized.Internal.Index.quot#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , Just (i,j) <- indexLiterals args+ -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `quot` j))+ "Clash.Sized.Internal.Index.rem#"+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , Just (i,j) <- indexLiterals args+ -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `rem` j))+ "Clash.Sized.Internal.Index.toInteger#"+ | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+ , primName p == "Clash.Sized.Internal.Index.fromInteger#"+ -> reduce (integerToIntegerLiteral i)++-- Resize+ "Clash.Sized.Internal.Index.resize#"+ | Just (mTy,m) <- extractKnownNat tcm tys+ , [i] <- indexLiterals' args+ -> reduce (mkIndexLit ty mTy m i)++---------+-- Signed+---------+ "Clash.Sized.Internal.Signed.size#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+ "Clash.Sized.Internal.Signed.pack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkBitVectorLit ty nTy kn 0 val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.pack# s)+ "Clash.Sized.Internal.Signed.unpack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [(0,i)] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op s _ = toInteger (Signed.unpack# s)++-- Eq+ "Clash.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.Signed.lt#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.Signed.ge#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.Signed.gt#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+ "Clash.Sized.Internal.Signed.minBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let minB = negate (2 ^ (mb - 1))+ in reduce (mkSignedLit ty litTy mb minB)+ "Clash.Sized.Internal.Signed.maxBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ (mb - 1)) - 1+ in reduce (mkSignedLit ty litTy mb maxB)++-- Num+ "Clash.Sized.Internal.Signed.+#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)+ -> reduce (val)+ "Clash.Sized.Internal.Signed.-#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)+ -> reduce (val)+ "Clash.Sized.Internal.Signed.*#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)+ -> reduce (val)+ "Clash.Sized.Internal.Signed.negate#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.negate# s)+ "Clash.Sized.Internal.Signed.abs#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.abs# s)++-- ExtendingNum+ "Clash.Sized.Internal.Signed.plus#"+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))++ "Clash.Sized.Internal.Signed.minus#"+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))++ "Clash.Sized.Internal.Signed.times#"+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+ "Clash.Sized.Internal.Signed.quot#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.rem#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.div#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.mod#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Signed.toInteger#"+ | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+ , primName p == "Clash.Sized.Internal.Signed.fromInteger#"+ -> reduce (integerToIntegerLiteral i)++-- Bits+ "Clash.Sized.Internal.Signed.and#"+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i .&. j))+ "Clash.Sized.Internal.Signed.or#"+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i .|. j))+ "Clash.Sized.Internal.Signed.xor#"+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i `xor` j))++ "Clash.Sized.Internal.Signed.complement#"+ | [i] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op u _ = toInteger (Signed.complement# u)++ "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)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.shiftL# u i)+ "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)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.shiftR# u i)+ "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)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.rotateL# u i)+ "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)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.rotateR# u i)++-- Resize+ "Clash.Sized.Internal.Signed.resize#" -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m+ | mTy : nTy : _ <- tys+ , Right mInt <- runExcept (tyNatSize tcm mTy)+ , Right nInt <- runExcept (tyNatSize tcm nTy)+ , [i] <- signedLiterals' args+ -> let val | nInt <= mInt = extended+ | otherwise = truncated+ extended = i+ mask = 1 `shiftL` fromInteger (mInt - 1)+ i' = i `mod` mask+ truncated = if testBit i (fromInteger nInt - 1)+ then (i' - mask)+ else i'+ in reduce (mkSignedLit ty mTy mInt val)+ "Clash.Sized.Internal.Signed.truncateB#" -- KnownNat m => Signed (m + n) -> Signed m+ | Just (mTy, km) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let bitsKeep = (bit (fromInteger km)) - 1+ val = i .&. bitsKeep+ in reduce (mkSignedLit ty mTy km val)++-- SaturatingNum+-- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#+-- It is just implemented in terms of other primitives.+++-----------+-- Unsigned+-----------+ "Clash.Sized.Internal.Unsigned.size#"+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,ty') = splitFunForallTy ty+ (TyConApp intTcNm _) = tyView ty'+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+ "Clash.Sized.Internal.Unsigned.pack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- unsignedLiterals' args+ -> reduce (mkBitVectorLit ty nTy kn 0 i)+ "Clash.Sized.Internal.Unsigned.unpack#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (toBV i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.unpack# u)++-- Eq+ "Clash.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ "Clash.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ "Clash.Sized.Internal.Unsigned.lt#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ "Clash.Sized.Internal.Unsigned.ge#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ "Clash.Sized.Internal.Unsigned.gt#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+ "Clash.Sized.Internal.Unsigned.minBound#"+ | Just (nTy,len) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy len 0)+ "Clash.Sized.Internal.Unsigned.maxBound#"+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ mb) - 1+ in reduce (mkUnsignedLit ty litTy mb maxB)++-- Num+ "Clash.Sized.Internal.Unsigned.+#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.Unsigned.-#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.Unsigned.*#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)+ -> reduce val+ "Clash.Sized.Internal.Unsigned.negate#"+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- unsignedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.negate# u)++-- ExtendingNum+ "Clash.Sized.Internal.Unsigned.plus#" -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)+ | Just (i,j) <- unsignedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))++ "Clash.Sized.Internal.Unsigned.minus#"+ | [i,j] <- unsignedLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)++ "Clash.Sized.Internal.Unsigned.times#"+ | Just (i,j) <- unsignedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+ "Clash.Sized.Internal.Unsigned.quot#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Unsigned.rem#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ "Clash.Sized.Internal.Unsigned.toInteger#"+ | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+ , primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"+ -> reduce (integerToIntegerLiteral i)++-- Bits+ "Clash.Sized.Internal.Unsigned.and#"+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i .&. j))+ "Clash.Sized.Internal.Unsigned.or#"+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i .|. j))+ "Clash.Sized.Internal.Unsigned.xor#"+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))++ "Clash.Sized.Internal.Unsigned.complement#"+ | [i] <- unsignedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.complement# u)++ "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)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.shiftL# u i)+ "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)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.shiftR# u i)+ "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)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.rotateL# u i)+ "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)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.rotateR# u i)++-- Resize+ "Clash.Sized.Internal.Unsigned.resize#" -- forall n m . KnownNat m => Unsigned n -> Unsigned m+ | _ : mTy : _ <- tys+ , Right km <- runExcept (tyNatSize tcm mTy)+ , [i] <- unsignedLiterals' args+ -> let bitsKeep = (bit (fromInteger km)) - 1+ val = i .&. bitsKeep+ in reduce (mkUnsignedLit ty mTy km val)++-- Conversions+ "Clash.Sized.Internal.Unsigned.unsignedToWord"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsignedToWord (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Sized.Internal.Unsigned.unsigned8toWord8"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned8toWord8 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Sized.Internal.Unsigned.unsigned16toWord16"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned16toWord16 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Sized.Internal.Unsigned.unsigned32toWord32"+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned32toWord32 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = lookupUniqMap wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"+ | isSubj+ , f : a : _ <- args+ -> reduceWHNF (mkApps (valToTerm f) [Left (valToTerm a)])++--------+-- RTree+--------+ "Clash.Sized.RTree.textract"+ | isSubj+ , [DC _ tArgs] <- args+ -> reduceWHNF (Either.lefts tArgs !! 1)++ "Clash.Sized.RTree.tsplit"+ | isSubj+ , dTy : aTy : _ <- tys+ , [DC _ tArgs] <- args+ , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty+ , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)+ -> let (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ in reduce $+ mkApps (Data tupDc)+ [Right (mkTyConApp treeTcNm [dTy,aTy])+ ,Right (mkTyConApp treeTcNm [dTy,aTy])+ ,Left (Either.lefts tArgs !! 1)+ ,Left (Either.lefts tArgs !! 2)+ ]++ "Clash.Sized.RTree.tdfold"+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : g : ts : _ <- args+ , DC _ tArgs <- ts+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])+ _ -> let k'ty = LitTy (NumTy (k'-1))+ (tyArgs,_) = splitFunForallTy ty+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduceWHNF $+ mkApps (valToTerm g)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Either.lefts tArgs !! 1)+ ])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Either.lefts tArgs !! 2)+ ])+ ]++ "Clash.Sized.RTree.treplicate"+ | isSubj+ , let ty' = piResultTys tcm ty tys+ , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'+ , Right len <- runExcept (tyNatSize tcm lenTy)+ -> let (Just treeTc) = lookupUniqMap treeTcNm tcm+ [lrCon,brCon] = tyConDataCons treeTc+ in reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))++---------+-- Vector+---------+ "Clash.Sized.Vector.length" -- :: KnownNat n => Vec n a -> Int+ | isSubj+ , [nTy, _] <- tys+ , Right n <-runExcept (tyNatSize tcm nTy)+ -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])++ "Clash.Sized.Vector.maxIndex"+ | isSubj+ , [nTy, _] <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = lookupUniqMap intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])++-- Indexing+ "Clash.Sized.Vector.index_int" -- :: KnownNat n => Vec n a -> Int+ | nTy : aTy : _ <- tys+ , _ : xs : i : _ <- args+ , DC intDc [Left (Literal (IntLiteral i'))] <- i+ -> if i' < 0+ then Nothing+ else case xs of+ DC _ vArgs -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> Nothing+ Right n' ->+ if i' == 0+ then reduceWHNF (Either.lefts vArgs !! 1)+ else reduceWHNF $+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Data intDc)+ [Left (Literal (IntLiteral (i'-1)))])+ ]+ _ -> Nothing+ _ -> Nothing+ "Clash.Sized.Vector.head" -- :: Vec (n+1) a -> a+ | isSubj+ , [DC _ vArgs] <- args+ -> reduceWHNF (Either.lefts vArgs !! 1)+ "Clash.Sized.Vector.last" -- :: Vec (n+1) a -> a+ | isSubj+ , [DC _ vArgs] <- args+ , (Right _ : Right aTy : Right nTy : _) <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> if n == 0+ then reduceWHNF (Either.lefts vArgs !! 1)+ else reduceWHNF+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)+ ])+-- - Sub-vectors+ "Clash.Sized.Vector.tail" -- :: Vec (n+1) a -> Vec n a+ | isSubj+ , [DC _ vArgs] <- args+ -> reduceWHNF (Either.lefts vArgs !! 2)+ "Clash.Sized.Vector.init" -- :: Vec (n+1) a -> Vec n a+ | isSubj+ , [DC consCon vArgs] <- args+ , (Right _ : Right aTy : Right nTy : _) <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> if n == 0+ then reduceWHNF (Either.lefts vArgs !! 2)+ else reduce $+ mkVecCons consCon aTy n+ (Either.lefts vArgs !! 1)+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)])+ "Clash.Sized.Vector.select" -- :: (CmpNat (i+s) (s*n) ~ GT) => SNat f -> SNat s -> SNat n -> Vec (f + i) a -> Vec n a+ | isSubj+ , iTy : sTy : nTy : fTy : aTy : _ <- tys+ , eq : f : s : n : xs : _ <- args+ , Right n' <- runExcept (tyNatSize tcm nTy)+ , Right f' <- runExcept (tyNatSize tcm fTy)+ , Right i' <- runExcept (tyNatSize tcm iTy)+ , Right s' <- runExcept (tyNatSize tcm sTy)+ , DC _ vArgs <- xs+ -> case n' of+ 0 -> reduce (mkVecNil nilCon aTy)+ _ -> case f' of+ 0 -> let splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right sTy+ ,Right (LitTy (NumTy (i'-s')))+ ,Right aTy+ ,Left (valToTerm s)+ ,Left (valToTerm xs)+ ]+ fVecTy = mkTyConApp vecTcNm [sTy,aTy]+ iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ fNm = mkUnsafeSystemName "fxs" 0+ iNm = mkUnsafeSystemName "ixs" 1+ fId = mkLocalId fVecTy fNm+ iId = mkLocalId iVecTy iNm+ tupPat = DataPat tupDc [] [fId,iId]+ iAlt = (tupPat, (Var iId))+ in reduce $+ mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (i'-s')))+ ,Right sTy+ ,Right (LitTy (NumTy (n'-1)))+ ,Right (LitTy (NumTy 0))+ ,Right aTy+ ,Left (valToTerm eq)+ ,Left (Literal (NaturalLiteral 0))+ ,Left (valToTerm s)+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Case splitAtCall iVecTy [iAlt])+ ]+ _ -> let splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right fTy+ ,Right iTy+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (valToTerm xs)+ ]+ fVecTy = mkTyConApp vecTcNm [fTy,aTy]+ iVecTy = mkTyConApp vecTcNm [iTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ fNm = mkUnsafeSystemName "fxs" 0+ iNm = mkUnsafeSystemName "ixs" 1+ fId = mkLocalId fVecTy fNm+ iId = mkLocalId iVecTy iNm+ tupPat = DataPat tupDc [] [fId,iId]+ iAlt = (tupPat, (Var iId))+ in reduceWHNF $+ mkApps (Prim pInfo)+ [Right iTy+ ,Right sTy+ ,Right nTy+ ,Right (LitTy (NumTy 0))+ ,Right aTy+ ,Left (valToTerm eq)+ ,Left (Literal (NaturalLiteral 0))+ ,Left (valToTerm s)+ ,Left (valToTerm n)+ ,Left (Case splitAtCall iVecTy [iAlt])+ ]+ where+ (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+-- - Splitting+ "Clash.Sized.Vector.splitAt" -- :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+ | isSubj+ , DC snatDc (Right mTy:_) <- head args+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> let _:nTy:aTy:_ = tys+ -- Get the tuple data-constructor+ ty1 = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty1+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ -- Get the vector data-constructors+ TyConApp vecTcNm _ = tyView (head tyArgs)+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ -- Recursive call to @splitAt@+ splitAtRec v =+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (m-1)))+ ,Right nTy+ ,Right aTy+ ,Left (mkApps (Data snatDc)+ [ Right (LitTy (NumTy (m-1)))+ , 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+ lNm = mkUnsafeSystemName "l" 0+ rNm = mkUnsafeSystemName "r" 1+ lId = mkLocalId m1VecTy lNm+ rId = mkLocalId nVecTy rNm+ tupPat = DataPat tupDc [] [lId,rId]+ lAlt = (tupPat, (Var lId))+ rAlt = (tupPat, (Var rId))++ in case m of+ -- (Nil,v)+ 0 -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecNil nilCon aTy)+ , Left (valToTerm (last args))+ ]+ -- (x:xs) <- v+ m' | DC _ vArgs <- last args+ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+ -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+ (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))+ , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])+ ]+ -- v doesn't reduce to a data-constructor+ _ -> Nothing++ "Clash.Sized.Vector.unconcat" -- :: KnownNat n => SNamt m -> Vec (n * m) a -> Vec n (Vec m a)+ | isSubj+ , kn : snat : v : _ <- args+ , nTy : mTy : aTy :_ <- tys+ , Lit (NaturalLiteral n) <- kn+ -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =+ splitFunForallTy ty+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ TyConApp snatTcNm _ = tyView (argTys !! 1)+ n1mTy = mkTyConApp typeNatMul+ [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]+ ,mTy]+ splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right mTy+ ,Right n1mTy+ ,Right aTy+ ,Left (valToTerm snat)+ ,Left (valToTerm v)+ ]+ mVecTy = mkTyConApp vecTcNm [mTy,aTy]+ n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ asNm = mkUnsafeSystemName "as" 0+ bsNm = mkUnsafeSystemName "bs" 1+ asId = mkLocalId mVecTy asNm+ bsId = mkLocalId n1mVecTy bsNm+ tupPat = DataPat tupDc [] [asId,bsId]+ asAlt = (tupPat, (Var asId))+ bsAlt = (tupPat, (Var bsId))++ in case n of+ 0 -> reduce (mkVecNil nilCon mVecTy)+ _ -> reduce $+ mkVecCons consCon mVecTy n+ (Case splitAtCall mVecTy [asAlt])+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right mTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n-1)))+ ,Left (valToTerm snat)+ ,Left (Case splitAtCall n1mVecTy [bsAlt])])+-- Construction+-- - initialisation+ "Clash.Sized.Vector.replicate" -- :: SNat n -> a -> Vec n a+ | isSubj+ , let ty' = piResultTys tcm ty tys+ , let (_,resTy) = splitFunForallTy ty'+ , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy+ , Right len <- runExcept (tyNatSize tcm lenTy)+ -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduce $+ mkVec nilCon consCon argTy len+ (replicate (fromInteger len) (valToTerm (last args)))+-- - Concatenation+ "Clash.Sized.Vector.++" -- :: Vec n a -> Vec m a -> Vec (n + m) a+ | isSubj+ , DC dc vArgs <- head args+ , Right nTy : Right aTy : _ <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (valToTerm (last args))+ n' | (_ : _ : mTy : _) <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> -- x : (xs ++ ys)+ reduce $+ mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Right mTy+ ,Left (Either.lefts vArgs !! 2)+ ,Left (valToTerm (last args))+ ])+ _ -> Nothing+ "Clash.Sized.Vector.concat" -- :: Vec n (Vec m a) -> Vec (n * m) a+ | isSubj+ , (nTy : mTy : aTy : _) <- tys+ , (xs : _) <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ _ | _ : h' : t : _ <- Either.lefts vArgs+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ -> reduceWHNF $+ mkApps (vecAppendPrim vecTcNm)+ [Right mTy+ ,Right aTy+ ,Right $ mkTyConApp typeNatMul+ [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]+ ,Left h'+ ,Left $ mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n-1)))+ , Right mTy+ , Right aTy+ , Left t+ ]+ ]+ _ -> Nothing++-- Modifying vectors+ "Clash.Sized.Vector.replace_int" -- :: KnownNat n => Vec n a -> Int -> a -> Vec n a+ | nTy : aTy : _ <- tys+ , _ : xs : i : a : _ <- args+ , DC intDc [Left (Literal (IntLiteral i'))] <- i+ -> if i' < 0+ then Nothing+ else case xs of+ DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> Nothing+ Right n' ->+ if i' == 0+ then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))+ else reduce $+ mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Data intDc)+ [Left (Literal (IntLiteral (i'-1)))])+ ,Left (valToTerm a)+ ])+ _ -> Nothing+ _ -> Nothing++ "Clash.Transformations.eqInt"+ | [ DC _ [Left (Literal (IntLiteral i))]+ , DC _ [Left (Literal (IntLiteral j))]+ ] <- args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++-- - specialized permutations+ "Clash.Sized.Vector.reverse" -- :: Vec n a -> Vec n a+ | isSubj+ , nTy : aTy : _ <- tys+ , [DC vecDc vArgs] <- args+ -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> reduce (mkVecNil vecDc aTy)+ Right n+ | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , let (Just vecTc) = lookupUniqMap vecTcNm tcm+ , let [nilCon,consCon] = tyConDataCons vecTc+ -> reduceWHNF $+ mkApps (vecAppendPrim vecTcNm)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Right (LitTy (NumTy 1))+ ,Left (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)+ ])+ ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])+ ]+ _ -> Nothing+ "Clash.Sized.Vector.transpose" -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)+ | isSubj+ , nTy : mTy : aTy : _ <- tys+ , kn : xss : _ <- args+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , DC _ vArgs <- xss+ , Right n <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> case m of+ 0 -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduce $+ mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n+ (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))+ m' -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ Just (consCoTy : _) = dataConInstArgTys consCon+ [mTy,aTy,LitTy (NumTy (m'-1))]+ in reduceWHNF $+ mkApps (vecZipWithPrim vecTcNm)+ [ Right aTy+ , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])+ , Right (mkTyConApp vecTcNm [mTy,aTy])+ , Right nTy+ , Left (mkApps (Data consCon)+ [Right mTy+ ,Right aTy+ ,Right (LitTy (NumTy (m'-1)))+ ,Left (primCo consCoTy)+ ])+ , Left (Either.lefts vArgs !! 1)+ , Left (mkApps (Prim pInfo)+ [ Right nTy+ , Right (LitTy (NumTy (m'-1)))+ , Right aTy+ , Left (valToTerm kn)+ , Left (Either.lefts vArgs !! 2)+ ])+ ]++ "Clash.Sized.Vector.rotateLeftS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a+ | nTy : aTy : _ : _ <- tys+ , kn : xs : d : _ <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ n' | DC snatDc [_,Left d'] <- d+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf eval tcm isSubj (setTerm d' $ stackClear mach)+ -> case (d2 `mod` n) of+ 0 -> reduce (valToTerm xs)+ d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduceWHNF' mach2 $+ mkApps (Prim pInfo)+ [Right nTy+ ,Right aTy+ ,Right (LitTy (NumTy (d3-1)))+ ,Left (valToTerm kn)+ ,Left (mkApps (vecAppendPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Right (LitTy (NumTy 1))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])+ ,Left (mkApps (Data snatDc)+ [Right (LitTy (NumTy (d3-1)))+ ,Left (Literal (NaturalLiteral (d3-1)))])+ ]+ _ -> Nothing++ "Clash.Sized.Vector.rotateRightS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a+ | isSubj+ , nTy : aTy : _ : _ <- tys+ , kn : xs : d : _ <- args+ , DC dc _ <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ n' | DC snatDc [_,Left d'] <- d+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf eval tcm isSubj (setTerm d' $ stackClear mach)+ -> case (d2 `mod` n) of+ 0 -> reduce (valToTerm xs)+ d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ in reduceWHNF' mach2 $+ mkApps (Prim pInfo)+ [Right nTy+ ,Right aTy+ ,Right (LitTy (NumTy (d3-1)))+ ,Left (valToTerm kn)+ ,Left (mkVecCons dc aTy n+ (mkApps (vecLastPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (valToTerm xs)])+ (mkApps (vecInitPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (valToTerm xs)]))+ ,Left (mkApps (Data snatDc)+ [Right (LitTy (NumTy (d3-1)))+ ,Left (Literal (NaturalLiteral (d3-1)))])+ ]+ _ -> Nothing+-- Element-wise operations+-- - mapping+ "Clash.Sized.Vector.map" -- :: (a -> b) -> Vec n a -> Vec n b+ | isSubj+ , DC dc vArgs <- args !! 1+ , aTy : bTy : nTy : _ <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc bTy)+ n' -> reduce $+ mkVecCons dc bTy n'+ (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])+ (mkApps (Prim pInfo)+ [Right aTy+ ,Right bTy+ ,Right (LitTy (NumTy (n' - 1)))+ ,Left (valToTerm (args !! 0))+ ,Left (Either.lefts vArgs !! 2)])+ "Clash.Sized.Vector.imap" -- :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b+ | isSubj+ , nTy : aTy : bTy : _ <- tys+ , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)+ , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , let iLit = mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0+ -> reduceWHNF $+ mkApps (Prim (PrimInfo "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm) WorkNever SingleResult))+ [Right nTy+ ,Right nTy+ ,Right aTy+ ,Right bTy+ ,Left iLit+ ,Left (valToTerm (args !! 1))+ ,Left (valToTerm (args !! 2))+ ]++ "Clash.Sized.Vector.imap_go"+ | isSubj+ , nTy : mTy : aTy : bTy : _ <- tys+ , n : f : xs : _ <- args+ , DC dc vArgs <- xs+ , Right n' <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> case m of+ 0 -> reduce (mkVecNil dc bTy)+ m' -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 0)+ iLit = mkIndexLit (Either.rights tyArgs !! 0) nTy n' 1+ in reduce $ mkVecCons dc bTy m'+ (mkApps (valToTerm f) [Left (valToTerm n),Left (Either.lefts vArgs !! 1)])+ (mkApps (Prim pInfo)+ [Right nTy+ ,Right (LitTy (NumTy (m'-1)))+ ,Right aTy+ ,Right bTy+ ,Left (mkApps (Prim (PrimInfo "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm) WorkVariable SingleResult))+ [Right nTy+ ,Left (Literal (NaturalLiteral n'))+ ,Left (valToTerm n)+ ,Left iLit+ ])+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ])++ -- :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a+ "Clash.Sized.Vector.iterateI"+ | isSubj+ , [nTy, aTy] <- tys+ , [_n, f, a] <- args+ , Right n <- runExcept (tyNatSize tcm nTy)+ ->+ let+ TyConApp vecTcNm _ = tyView (getResultTy tcm ty tys)+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon, consCon] = tyConDataCons vecTc+ in case n of+ 0 -> reduce (mkVecNil nilCon aTy)+ _ -> reduce $+ mkVecCons consCon aTy n+ (valToTerm a)+ (mkApps+ (Prim pInfo)+ [ Right (LitTy (NumTy (n - 1)))+ , Right aTy+ , Left (valToTerm (Lit (NaturalLiteral (n - 1))))+ , Left (valToTerm f)+ , Left (mkApps (valToTerm f) [Left (valToTerm a)])+ ])++-- - Zipping+ "Clash.Sized.Vector.zipWith" -- :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c+ | isSubj+ , aTy : bTy : cTy : nTy : _ <- tys+ , f : xs : ys : _ <- args+ , DC dc vArgs <- xs+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc cTy)+ n' -> reduce $ mkVecCons dc cTy n'+ (mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (vecHeadPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right bTy+ ,Left (valToTerm ys)+ ])+ ])+ (mkApps (Prim pInfo)+ [Right aTy+ ,Right bTy+ ,Right cTy+ ,Right (LitTy (NumTy (n' - 1)))+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (vecTailPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right bTy+ ,Left (valToTerm ys)+ ])])++-- Folding+ "Clash.Sized.Vector.foldr" -- :: (a -> b -> b) -> b -> Vec n a -> b+ | isSubj+ , aTy : bTy : nTy : _ <- tys+ , f : z : xs : _ <- args+ , DC _ vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (valToTerm z)+ _ -> reduceWHNF $+ mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (Prim pInfo)+ [Right aTy+ ,Right bTy+ ,Right (LitTy (NumTy (n-1)))+ ,Left (valToTerm f)+ ,Left (valToTerm z)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ "Clash.Sized.Vector.fold" -- :: (a -> a -> a) -> Vec (n + 1) a -> a+ | isSubj+ , nTy : aTy : _ <- tys+ , f : vs : _ <- args+ , DC _ vArgs <- vs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduceWHNF (Either.lefts vArgs !! 1)+ _ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ n' = n+1+ m = n' `div` 2+ n1 = n' - m+ mTy = LitTy (NumTy m)+ m'ty = LitTy (NumTy (m-1))+ n1mTy = LitTy (NumTy n1)+ n1m'ty = LitTy (NumTy (n1-1))+ splitAtCall =+ mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever SingleResult))+ [Right mTy+ ,Right n1mTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral m))+ ,Left (valToTerm vs)+ ]+ mVecTy = mkTyConApp vecTcNm [mTy,aTy]+ n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ asNm = mkUnsafeSystemName "as" 0+ bsNm = mkUnsafeSystemName "bs" 1+ asId = mkLocalId mVecTy asNm+ bsId = mkLocalId n1mVecTy bsNm+ tupPat = DataPat tupDc [] [asId,bsId]+ asAlt = (tupPat, (Var asId))+ bsAlt = (tupPat, (Var bsId))+ in reduceWHNF $+ mkApps (valToTerm f)+ [Left (mkApps (Prim pInfo)+ [Right m'ty+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (Case splitAtCall mVecTy [asAlt])+ ])+ ,Left (mkApps (Prim pInfo)+ [Right n1m'ty+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (Case splitAtCall n1mVecTy [bsAlt])+ ])+ ]+++ "Clash.Sized.Vector.fold_split" -- :: Natural -> Vec (m + n) a -> (Vec m a, Vec n a)+ | isSubj+ , mTy : nTy : aTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> let -- Get the tuple data-constructor+ ty1 = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty1+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ -- Get the vector data-constructors+ TyConApp vecTcNm _ = tyView (head tyArgs)+ Just vecTc = lookupUniqMap vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ -- Recursive call to @splitAt@+ splitAtRec v =+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (m-1)))+ ,Right nTy+ ,Right aTy+ ,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+ lNm = mkUnsafeSystemName "l" 0+ rNm = mkUnsafeSystemName "r" 1+ lId = mkLocalId m1VecTy lNm+ rId = mkLocalId nVecTy rNm+ tupPat = DataPat tupDc [] [lId,rId]+ lAlt = (tupPat, (Var lId))+ rAlt = (tupPat, (Var rId))+ in case m of+ -- (Nil,v)+ 0 -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecNil nilCon aTy)+ , Left (valToTerm (last args))+ ]+ -- (x:xs) <- v+ m' | DC _ vArgs <- last args+ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+ -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+ (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))+ , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])+ ]+ -- v doesn't reduce to a data-constructor+ _ -> Nothing+-- - Specialised folds+ "Clash.Sized.Vector.dfold"+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : z : xs : _ <- args+ , DC _ vArgs <- xs+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduce (valToTerm z)+ _ -> let (tyArgs,_) = splitFunForallTy ty+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ k'ty = LitTy (NumTy (k'-1))+ in reduceWHNF $+ mkApps (valToTerm f)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm z)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ "Clash.Sized.Vector.dtfold"+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : g : xs : _ <- args+ , DC _ vArgs <- xs+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])+ _ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = lookupUniqMap snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ k'ty = LitTy (NumTy (k'-1))+ k2ty = LitTy (NumTy (2^(k'-1)))+ splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right k2ty+ ,Right k2ty+ ,Right aTy+ ,Left (mkApps (Data snatDc)+ [Right k2ty+ ,Left (Literal (NaturalLiteral (2^(k'-1))))])+ ,Left (valToTerm xs)+ ]+ xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ xsLNm = mkUnsafeSystemName "xsL" 0+ xsRNm = mkUnsafeSystemName "xsR" 1+ xsLId = mkLocalId k2ty xsLNm+ xsRId = mkLocalId k2ty xsRNm+ tupPat = DataPat tupDc [] [xsLId,xsRId]+ asAlt = (tupPat, (Var xsLId))+ bsAlt = (tupPat, (Var xsRId))+ in reduceWHNF $+ mkApps (valToTerm g)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Case splitAtCall xsSVecTy [asAlt])])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Case splitAtCall xsSVecTy [bsAlt])])+ ]+-- Misc+ "Clash.Sized.Vector.lazyV"+ | isSubj+ , nTy : aTy : _ <- tys+ , _ : xs : _ <- args+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,_] = tyConDataCons vecTc+ in reduce (mkVecNil nilCon aTy)+ n' -> let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ in reduce $ mkVecCons consCon aTy n'+ (mkApps (vecHeadPrim vecTcNm)+ [ Right (LitTy (NumTy (n' - 1)))+ , Right aTy+ , Left (valToTerm xs)+ ])+ (mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n' - 1)))+ , Right aTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (mkApps (vecTailPrim vecTcNm)+ [ Right (LitTy (NumTy (n'-1)))+ , Right aTy+ , Left (valToTerm xs)+ ])+ ])+-- Traversable+ "Clash.Sized.Vector.traverse#"+ | isSubj+ , aTy : fTy : bTy : nTy : _ <- tys+ , apDict : f : xs : _ <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 1) ids+ in reduceWHNF' (mach { mSupply = ids' }) $+ mkApps pureF+ [Right (mkTyConApp (vecTcNm) [nTy,bTy])+ ,Left (mkVecNil dc bTy)]+ _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do+ fDict <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 0+ fmapF' <- mkSelectorCase $(curLoc) is0 tcm fDict 1 0+ apF' <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 2+ return (fmapF',apF')+ n'ty = LitTy (NumTy (n-1))+ Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]+ in reduceWHNF' (mach { mSupply = ids' }) $+ mkApps apF+ [Right (mkTyConApp vecTcNm [n'ty,bTy])+ ,Right (mkTyConApp vecTcNm [nTy,bTy])+ ,Left (mkApps fmapF+ [Right bTy+ ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])+ (mkTyConApp vecTcNm [nTy,bTy]))+ ,Left (mkApps (Data dc)+ [Right nTy+ ,Right bTy+ ,Right n'ty+ ,Left (primCo consCoTy)])+ ,Left (mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)])+ ])+ ,Left (mkApps (Prim pInfo)+ [Right aTy+ ,Right fTy+ ,Right bTy+ ,Right n'ty+ ,Left (valToTerm apDict)+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ where+ (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)+ (ids, is0) = (mSupply mach, mScopeNames mach)++-- BitPack+ "Clash.Sized.Vector.concatBitVector#"+ | isSubj+ , nTy : mTy : _ <- tys+ , _ : km : v : _ <- args+ , DC _ vArgs <- v+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo 0 0)+ n' | Right m <- runExcept (tyNatSize tcm mTy)+ , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty+ -> reduceWHNF $+ mkApps (bvAppendPrim bvTcNm)+ [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+ , Right mTy+ , Left (Literal (NaturalLiteral ((n'-1)*m)))+ , Left (Either.lefts vArgs !! 1)+ , Left (mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n'-1)))+ , Right mTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (valToTerm km)+ , Left (Either.lefts vArgs !! 2)+ ])+ ]+ _ -> Nothing+ "Clash.Sized.Vector.unconcatBitVector#"+ | isSubj+ , nTy : mTy : _ <- tys+ , _ : km : bv : _ <- args+ , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty+ , TyConApp bvTcNm _ <- tyView bvMTy+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 ->+ let (Just vecTc) = lookupUniqMap vecTcNm tcm+ [nilCon,_] = tyConDataCons vecTc+ in reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))+ n' | Right m <- runExcept (tyNatSize tcm mTy) ->+ let Just vecTc = lookupUniqMap vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ Just tupTc = lookupUniqMap tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ splitCall =+ mkApps (bvSplitPrim bvTcNm)+ [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+ , Right mTy+ , Left (Literal (NaturalLiteral ((n'-1)*m)))+ , Left (valToTerm bv)+ ]+ mBVTy = mkTyConApp bvTcNm [mTy]+ n1BVTy = mkTyConApp bvTcNm+ [mkTyConApp typeNatMul+ [LitTy (NumTy (n'-1))+ ,mTy]]+ -- Guaranteed no capture, so okay to use unsafe name generation+ xNm = mkUnsafeSystemName "x" 0+ bvNm = mkUnsafeSystemName "bv'" 1+ xId = mkLocalId mBVTy xNm+ bvId = mkLocalId n1BVTy bvNm+ tupPat = DataPat tupDc [] [xId,bvId]+ xAlt = (tupPat, (Var xId))+ bvAlt = (tupPat, (Var bvId))++ in reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'+ (Case splitCall mBVTy [xAlt])+ (mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n'-1)))+ , Right mTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (valToTerm km)+ , Left (Case splitCall n1BVTy [bvAlt])+ ])+ _ -> Nothing+ _ -> Nothing+ where+ ty = primType pInfo++ checkNaturalRange1 nTy i f =+ checkNaturalRange nTy [i]+ (\[i'] -> naturalToNaturalLiteral (f i'))++ checkNaturalRange2 nTy i j f =+ checkNaturalRange nTy [i, j]+ (\[i', j'] -> naturalToNaturalLiteral (f i' j'))++ -- Check given integer's range. If any of them are less than zero, give up+ -- and return an undefined type.+ checkNaturalRange+ :: Type+ -- Type of GHC.Natural.Natural ^+ -> [Integer]+ -> ([Natural] -> Term)+ -> Term+ checkNaturalRange nTy natsAsInts f =+ if any (<0) natsAsInts then+ undefinedTm nTy+ else+ f (map fromInteger natsAsInts)++ reduce :: Term -> Maybe Machine+ reduce 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)++ reduceWHNF e =+ let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ mach1@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e $ stackClear mach)+ in Just $ mach1 { mStack = mStack mach }++ reduceWHNF' mach1 e =+ let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ mach2@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e mach1)+ in Just $ mach2 { mStack = mStack mach }++ makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term+ makeUndefinedIf wantToHandle tm =+ case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of+ Right b -> b+ Left e -> trace (msg e) (undefinedTm resTy)+ where+ resTy = getResultTy tcm ty tys+ selectException e | wantToHandle e = Just e+ | otherwise = Nothing+ msg e = unlines ["Warning: caught exception: \"" ++ show e ++ "\" while trying to evaluate: "+ , showPpr (mkApps (Prim pInfo) (map (Left . valToTerm) args))+ ]++ catchDivByZero = makeUndefinedIf (==DivideByZero)++-- Helper functions for literals++pairOf :: (Value -> Maybe a) -> [Value] -> Maybe (a, a)+pairOf f [x, y] = (,) <$> f x <*> f y+pairOf _ _ = Nothing++listOf :: (Value -> Maybe a) -> [Value] -> [a]+listOf = mapMaybe++wrapUnsigned :: Integer -> Integer -> Integer+wrapUnsigned n i = i `mod` sz+ where+ sz = 1 `shiftL` fromInteger n++wrapSigned :: Integer -> Integer -> Integer+wrapSigned n i = if n == 0 then 0 else res+ where+ mask = 1 `shiftL` fromInteger (n - 1)+ res = case divMod i mask of+ (s,i1) | even s -> i1+ | otherwise -> i1 - mask++doubleLiterals' :: [Value] -> [Rational]+doubleLiterals' = listOf doubleLiteral++doubleLiteral :: Value -> Maybe Rational+doubleLiteral v = case v of+ Lit (DoubleLiteral i) -> Just i+ _ -> Nothing++floatLiterals' :: [Value] -> [Rational]+floatLiterals' = listOf floatLiteral++floatLiteral :: Value -> Maybe Rational+floatLiteral v = case v of+ Lit (FloatLiteral i) -> Just i+ _ -> Nothing++integerLiterals :: [Value] -> Maybe (Integer, Integer)+integerLiterals = pairOf integerLiteral++integerLiteral :: Value -> Maybe Integer+integerLiteral v =+ case v of+ Lit (IntegerLiteral i) -> Just i+ DC dc [Left (Literal (IntLiteral i))]+ | dcTag dc == 1+ -> Just i+ DC dc [Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))]+ | dcTag dc == 2+#if MIN_VERSION_base(4,15,0)+ -> Just (IP ba)+#else+ -> Just (Jp# (BN# ba))+#endif+ | dcTag dc == 3+#if MIN_VERSION_base(4,15,0)+ -> Just (IN ba)+#else+ -> Just (Jn# (BN# ba))+#endif+ _ -> Nothing++naturalLiterals :: [Value] -> Maybe (Integer, Integer)+naturalLiterals = pairOf naturalLiteral++naturalLiteral :: Value -> Maybe Integer+naturalLiteral v =+ case v of+ Lit (NaturalLiteral i) -> Just i+ DC dc [Left (Literal (WordLiteral i))]+ | dcTag dc == 1+ -> Just i+ DC dc [Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))]+ | dcTag dc == 2+#if MIN_VERSION_base(4,15,0)+ -> Just (IP ba)+#else+ -> Just (Jp# (BN# ba))+#endif+ _ -> Nothing++integerLiterals' :: [Value] -> [Integer]+integerLiterals' = listOf integerLiteral++naturalLiterals' :: [Value] -> [Integer]+naturalLiterals' = listOf naturalLiteral++intLiterals :: [Value] -> Maybe (Integer,Integer)+intLiterals = pairOf intLiteral++intLiterals' :: [Value] -> [Integer]+intLiterals' = listOf intLiteral++intLiteral :: Value -> Maybe Integer+intLiteral x = case x of+ Lit (IntLiteral i) -> Just i+ _ -> Nothing++intCLiteral :: Value -> Maybe Integer+intCLiteral v = case v of+ (DC _ [Left (Literal (IntLiteral i))]) -> Just i+ _ -> Nothing++intCLiterals :: [Value] -> Maybe (Integer, Integer)+intCLiterals = pairOf intCLiteral++wordLiterals :: [Value] -> Maybe (Integer,Integer)+wordLiterals = pairOf wordLiteral++wordLiterals' :: [Value] -> [Integer]+wordLiterals' = listOf wordLiteral++wordLiteral :: Value -> Maybe Integer+wordLiteral x = case x of+ Lit (WordLiteral i) -> Just i+ _ -> Nothing++charLiterals :: [Value] -> Maybe (Char,Char)+charLiterals = pairOf charLiteral++charLiterals' :: [Value] -> [Char]+charLiterals' = listOf charLiteral++charLiteral :: Value -> Maybe Char+charLiteral x = case x of+ Lit (CharLiteral c) -> Just c+ _ -> Nothing++sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)+sizedLiterals szCon = pairOf (sizedLiteral szCon)++sizedLiterals' :: Text -> [Value] -> [Integer]+sizedLiterals' szCon = listOf (sizedLiteral szCon)++sizedLiteral :: Text -> Value -> Maybe Integer+sizedLiteral szCon val = case val of+ PrimVal p _ [_, Lit (IntegerLiteral i)]+ | primName p == szCon -> Just i+ _ -> Nothing++bitLiterals+ :: [Value]+ -> [(Integer,Integer)]+bitLiterals = map normalizeBit . mapMaybe go+ where+ normalizeBit (msk,v) = (msk .&. 1, v .&. 1)+ go val = case val of+ PrimVal p _ [Lit (WordLiteral m), Lit (IntegerLiteral i)]+ | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"+ -> Just (m,i)+ _ -> Nothing++indexLiterals, signedLiterals, unsignedLiterals+ :: [Value] -> Maybe (Integer,Integer)+indexLiterals = sizedLiterals "Clash.Sized.Internal.Index.fromInteger#"+signedLiterals = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLiterals = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#"++indexLiterals', signedLiterals', unsignedLiterals'+ :: [Value] -> [Integer]+indexLiterals' = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#"+signedLiterals' = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLiterals' = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#"++bitVectorLiterals'+ :: [Value] -> [(Integer,Integer)]+bitVectorLiterals' = listOf bitVectorLiteral++bitVectorLiteral :: Value -> Maybe (Integer, Integer)+bitVectorLiteral val = case val of+ (PrimVal p _ [_, Lit (NaturalLiteral m), Lit (IntegerLiteral i)])+ | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (m, i)+ _ -> Nothing++toBV :: (Integer,Integer) -> BitVector n+toBV (mask,val) = BV (fromInteger mask) (fromInteger val)++splitBV :: BitVector n -> (Integer,Integer)+splitBV (BV msk val) = (toInteger msk, toInteger val)++toBit :: (Integer,Integer) -> Bit+toBit (mask,val) = Bit (fromInteger mask) (fromInteger val)++valArgs+ :: Value+ -> Maybe [Term]+valArgs v =+ case v of+ PrimVal _ _ vs -> Just (fmap valToTerm vs)+ DC _ args -> Just (Either.lefts args)+ _ -> Nothing++-- Tries to match literal arguments to a function like+-- (Unsigned.shiftL# :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)+sizedLitIntLit+ :: Text -> TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,Integer,Integer)+sizedLitIntLit szCon tcm tys args+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [_+ ,PrimVal p _ [_,Lit (IntegerLiteral i)]+ ,valArgs -> Just [Literal (IntLiteral j)]+ ] <- args+ , primName p == szCon+ = Just (nTy,kn,i,j)+ | otherwise+ = Nothing++signedLitIntLit, unsignedLitIntLit+ :: TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,Integer,Integer)+signedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Unsigned.fromInteger#"++bitVectorLitIntLit+ :: TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,(Integer,Integer),Integer)+bitVectorLitIntLit tcm tys args+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [_+ ,PrimVal p _ [_,Lit (NaturalLiteral m),Lit (IntegerLiteral i)]+ ,valArgs -> Just [Literal (IntLiteral j)]+ ] <- args+ , primName p == "Clash.Sized.Internal.BitVector.fromInteger#"+ = Just (nTy,kn,(m,i),j)+ | otherwise+ = Nothing++-- From an argument list to function of type+-- forall n. KnownNat n => ...+-- extract (nTy,nInt)+-- where nTy is the Type of n+-- and nInt is its value as an Integer+extractKnownNat :: TyConMap -> [Type] -> Maybe (Type, Integer)+extractKnownNat tcm tys = case tys of+ nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)+ -> Just (nTy, nInt)+ _ -> Nothing++-- From an argument list to function of type+-- forall n m o .. . (KnownNat n, KnownNat m, KnownNat o, ..) => ...+-- extract [(nTy,nInt), (mTy,mInt), (oTy,oInt)]+-- where nTy is the Type of n+-- and nInt is its value as an Integer+extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]+extractKnownNats tcm =+ mapMaybe (extractKnownNat tcm . pure)++-- Construct a constant term of a sized type+mkSizedLit+ :: (Type -> Term)+ -- ^ Type constructor?+ -> Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Term+mkSizedLit conPrim ty nTy kn val =+ mkApps+ (conPrim sTy)+ [ Right nTy+ , Left (Literal (NaturalLiteral kn))+ , Left (Literal (IntegerLiteral val)) ]+ where+ (_,sTy) = splitFunForallTy ty++mkBitLit+ :: Type+ -- ^ Result type+ -> Integer+ -- ^ Mask+ -> Integer+ -- ^ Value+ -> Term+mkBitLit ty msk val =+ mkApps (bConPrim sTy) [ Left (Literal (WordLiteral (msk .&. 1)))+ , Left (Literal (IntegerLiteral (val .&. 1)))]+ where+ (_,sTy) = splitFunForallTy ty++mkSignedLit, mkUnsignedLit+ :: Type+ -- Result type+ -> Type+ -- forall n.+ -> Integer+ -- KnownNat n+ -> Integer+ -- Value+ -> Term+mkSignedLit = mkSizedLit signedConPrim+mkUnsignedLit = mkSizedLit unsignedConPrim++mkBitVectorLit+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ mask+ -> Integer+ -- ^ Value to construct+ -> Term+mkBitVectorLit ty nTy kn mask val+ = mkApps (bvConPrim sTy)+ [Right nTy+ ,Left (Literal (NaturalLiteral kn))+ ,Left (Literal (NaturalLiteral mask))+ ,Left (Literal (IntegerLiteral val))]+ where+ (_,sTy) = splitFunForallTy ty++mkIndexLitE+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Either Term Term+ -- ^ Either undefined (if given value is out of bounds of given type) or term+ -- representing literal+mkIndexLitE rTy nTy kn val+ | val >= 0+ , val < kn+ = Right (mkSizedLit indexConPrim rTy nTy kn val)+ | otherwise+ = Left (undefinedTm (mkTyConApp indexTcNm [nTy]))+ where+ TyConApp indexTcNm _ = tyView (snd (splitFunForallTy rTy))++mkIndexLit+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Term+mkIndexLit rTy nTy kn val =+ either id id (mkIndexLitE rTy nTy kn val)++mkBitVectorLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ Mask+ -> Integer+ -- ^ Value+ -> Term+mkBitVectorLit' (ty,nTy,kn) = mkBitVectorLit ty nTy kn++mkIndexLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ value+ -> Term+mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn++boolToIntLiteral :: Bool -> Term+boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)++boolToBoolLiteral :: TyConMap -> Type -> Bool -> Term+boolToBoolLiteral tcm ty b =+ let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty+ (Just boolTc) = lookupUniqMap boolTcNm tcm+ [falseDc,trueDc] = tyConDataCons boolTc+ retDc = if b then trueDc else falseDc+ in Data retDc++charToCharLiteral :: Char -> Term+charToCharLiteral = Literal . CharLiteral++integerToIntLiteral :: Integer -> Term+integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behavior++integerToWordLiteral :: Integer -> Term+integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behavior++integerToIntegerLiteral :: Integer -> Term+integerToIntegerLiteral = Literal . IntegerLiteral++naturalToNaturalLiteral :: Natural -> Term+naturalToNaturalLiteral = Literal . NaturalLiteral . toInteger++bConPrim :: Type -> Term+bConPrim (tyView -> TyConApp bTcNm _)+ = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever SingleResult)+ where+ funTy = foldr1 mkFunTy [wordPrimTy,integerPrimTy,mkTyConApp bTcNm []]+bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++bvConPrim :: Type -> Term+bvConPrim (tyView -> TyConApp bvTcNm _)+ = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++indexConPrim :: Type -> Term+indexConPrim (tyView -> TyConApp indexTcNm _)+ = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++signedConPrim :: Type -> Term+signedConPrim (tyView -> TyConApp signedTcNm _)+ = Prim (PrimInfo "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++unsignedConPrim :: Type -> Term+unsignedConPrim (tyView -> TyConApp unsignedTcNm _)+ = Prim (PrimInfo "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"+++-- | Lift a binary function over 'Unsigned' values to be used as literal Evaluator+--+--+liftUnsigned2 :: KnownNat n+ => (Unsigned n -> Unsigned n -> Unsigned n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit++liftSigned2 :: KnownNat n+ => (Signed n -> Signed n -> Signed n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftSigned2 = liftSized2 signedLiterals' mkSignedLit++liftBitVector2 :: KnownNat n+ => (BitVector n -> BitVector n -> BitVector n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2 f ty tcm tys args _p+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i,j] <- bitVectorLiterals' args+ = let BV mask val = f (toBV i) (toBV j)+ in Just $ mkBitVectorLit ty nTy kn (toInteger mask) (toInteger val)+ | otherwise = Nothing++liftBitVector2Bool :: KnownNat n+ => (BitVector n -> BitVector n -> Bool)+ -> Type+ -> TyConMap+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2Bool f ty tcm args _p+ | [i,j] <- bitVectorLiterals' args+ = let val = f (toBV i) (toBV j)+ in Just $ boolToBoolLiteral tcm ty val+ | otherwise = Nothing++liftSized2 :: (KnownNat n, Integral (sized n))+ => ([Value] -> [Integer])+ -- ^ literal argument extraction function+ -> (Type -> Type -> Integer -> Integer -> Term)+ -- ^ literal contruction function+ -> (sized n -> sized n -> sized n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftSized2 extractLitArgs mkLit f ty tcm tys args p+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i,j] <- extractLitArgs args+ = let val = runSizedF f i j p+ in Just $ mkLit ty nTy kn val+ | otherwise = Nothing++-- | Helper to run a function over sized types on integers+--+-- This only works on function of type (sized n -> sized n -> sized n)+-- The resulting function must be executed with reifyNat+runSizedF+ :: (KnownNat n, Integral (sized n))+ => (sized n -> sized n -> sized n)+ -- ^ function to run+ -> Integer+ -- ^ first argument+ -> Integer+ -- ^ second argument+ -> (Proxy n -> Integer)+runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)++extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)+extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)+ where+ ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ TyConApp _ [resSizeTy] = tyView resTy+ Right resSize = runExcept (tyNatSize tcm resSizeTy)++getResultTy+ :: TyConMap+ -> Type+ -> [Type]+ -> Type+getResultTy tcm ty tys = resTy+ where+ ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'++liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term+liftDDI f args = case doubleLiterals' args of+ [i,j] -> Just $ runDDI f i j+ _ -> Nothing+liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term+liftDDD f args = case doubleLiterals' args of+ [i,j] -> Just $ runDDD f i j+ _ -> Nothing+liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term+liftDD f args = case doubleLiterals' args of+ [i] -> Just $ runDD f i+ _ -> Nothing+runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term+runDDI f i j+ = let !(D# a) = fromRational i+ !(D# b) = fromRational j+ r = f a b+ in Literal . IntLiteral . toInteger $ I# r+runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term+runDDD f i j+ = let !(D# a) = fromRational i+ !(D# b) = fromRational j+ r = f a b+ in Literal . DoubleLiteral . toRational $ D# r+runDD :: (Double# -> Double#) -> Rational -> Term+runDD f i+ = let !(D# a) = fromRational i+ r = f a+ in Literal . DoubleLiteral . toRational $ D# r++liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term+liftFFI f args = case floatLiterals' args of+ [i,j] -> Just $ runFFI f i j+ _ -> Nothing+liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term+liftFFF f args = case floatLiterals' args of+ [i,j] -> Just $ runFFF f i j+ _ -> Nothing+liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term+liftFF f args = case floatLiterals' args of+ [i] -> Just $ runFF f i+ _ -> Nothing+runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term+runFFI f i j+ = let !(F# a) = fromRational i+ !(F# b) = fromRational j+ r = f a b+ in Literal . IntLiteral . toInteger $ I# r+runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term+runFFF f i j+ = let !(F# a) = fromRational i+ !(F# b) = fromRational j+ r = f a b+ in Literal . FloatLiteral . toRational $ F# r+runFF :: (Float# -> Float#) -> Rational -> Term+runFF f i+ = let !(F# a) = fromRational i+ r = f a+ in Literal . FloatLiteral . toRational $ F# r++splitAtPrim+ :: TyConName+ -- ^ SNat TyCon name+ -> TyConName+ -- ^ Vec TyCon name+ -> Term+splitAtPrim snatTcNm vecTcNm =+ Prim (PrimInfo "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm) WorkNever SingleResult)++splitAtTy+ :: TyConName+ -- ^ SNat TyCon name+ -> TyConName+ -- ^ Vec TyCon name+ -> Type+splitAtTy snatNm vecNm =+ ForAllTy mTV (+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ (mkTyConApp snatNm [VarTy mTV])+ (mkFunTy+ (mkTyConApp vecNm+ [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]+ ,VarTy aTV])+ (mkTyConApp tupNm+ [mkTyConApp vecNm+ [VarTy mTV+ ,VarTy aTV]+ ,mkTyConApp vecNm+ [VarTy nTV+ ,VarTy aTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++foldSplitAtTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+foldSplitAtTy vecNm =+ ForAllTy mTV (+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ naturalPrimTy+ (mkFunTy+ (mkTyConApp vecNm+ [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]+ ,VarTy aTV])+ (mkTyConApp tupNm+ [mkTyConApp vecNm+ [VarTy mTV+ ,VarTy aTV]+ ,mkTyConApp vecNm+ [VarTy nTV+ ,VarTy aTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++vecAppendPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecAppendPrim vecNm =+ Prim (PrimInfo "Clash.Sized.Vector.++" (vecAppendTy vecNm) WorkNever SingleResult)++vecAppendTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecAppendTy vecNm =+ ForAllTy nTV (+ ForAllTy aTV (+ ForAllTy mTV (+ mkFunTy+ (mkTyConApp vecNm [VarTy nTV+ ,VarTy aTV+ ])+ (mkFunTy+ (mkTyConApp vecNm [VarTy mTV+ ,VarTy aTV+ ])+ (mkTyConApp vecNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,VarTy mTV]+ ,VarTy aTV+ ])))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 2)++vecZipWithPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecZipWithPrim vecNm =+ Prim (PrimInfo "Clash.Sized.Vector.zipWith" (vecZipWithTy vecNm) WorkNever SingleResult)++vecZipWithTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecZipWithTy vecNm =+ ForAllTy aTV (+ ForAllTy bTV (+ ForAllTy cTV (+ ForAllTy nTV (+ mkFunTy+ (mkFunTy aTy (mkFunTy bTy cTy))+ (mkFunTy+ (mkTyConApp vecNm [nTy,aTy])+ (mkFunTy+ (mkTyConApp vecNm [nTy,bTy])+ (mkTyConApp vecNm [nTy,cTy])))))))+ where+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+ bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)+ cTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "c" 2)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 3)+ aTy = VarTy aTV+ bTy = VarTy bTV+ cTy = VarTy cTV+ nTy = VarTy nTV++vecImapGoTy+ :: TyConName+ -- ^ Vec TyCon name+ -> TyConName+ -- ^ Index TyCon name+ -> Type+vecImapGoTy vecTcNm indexTcNm =+ ForAllTy nTV (+ ForAllTy mTV (+ ForAllTy aTV (+ ForAllTy bTV (+ mkFunTy indexTy+ (mkFunTy fTy+ (mkFunTy vecATy vecBTy))))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 3)+ indexTy = mkTyConApp indexTcNm [nTy]+ nTy = VarTy nTV+ mTy = VarTy mTV+ fTy = mkFunTy indexTy (mkFunTy aTy bTy)+ aTy = VarTy aTV+ bTy = VarTy bTV+ vecATy = mkTyConApp vecTcNm [mTy,aTy]+ vecBTy = mkTyConApp vecTcNm [mTy,bTy]++indexAddTy+ :: TyConName+ -- ^ Index TyCon name+ -> Type+indexAddTy indexTcNm =+ ForAllTy nTV (+ mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy)))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ indexTy = mkTyConApp indexTcNm [VarTy nTV]++bvAppendPrim+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Term+bvAppendPrim bvTcNm =+ Prim (PrimInfo "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm) WorkNever SingleResult)++bvAppendTy+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Type+bvAppendTy bvNm =+ ForAllTy mTV (+ ForAllTy nTV (+ mkFunTy naturalPrimTy (mkFunTy+ (mkTyConApp bvNm [VarTy nTV])+ (mkFunTy+ (mkTyConApp bvNm [VarTy mTV])+ (mkTyConApp bvNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,VarTy mTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)++bvSplitPrim+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Term+bvSplitPrim bvTcNm =+ Prim (PrimInfo "Clash.Sized.Internal.BitVector.split#" (bvSplitTy bvTcNm) WorkNever SingleResult)++bvSplitTy+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Type+bvSplitTy bvNm =+ ForAllTy nTV (+ ForAllTy mTV (+ mkFunTy naturalPrimTy (mkFunTy+ (mkTyConApp bvNm [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]])+ (mkTyConApp tupNm [mkTyConApp bvNm [VarTy mTV]+ ,mkTyConApp bvNm [VarTy nTV]]))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++ghcTyconToTyConName+ :: TyCon.TyCon+ -> TyConName+ghcTyconToTyConName tc =+ Name User n' (getKey (TyCon.tyConUnique tc)) (getSrcSpan n)+ where+ n' = fromMaybe "_INTERNAL_" (modNameM n) `Text.append`+ ('.' `Text.cons` Text.pack occName)+ occName = occNameString $ nameOccName n+ n = TyCon.tyConName tc++svoid :: (State# RealWorld -> State# RealWorld) -> IO ()+svoid m0 = IO (\s -> case m0 s of s' -> (# s', () #))++isTrueDC,isFalseDC :: DataCon -> Bool+isTrueDC dc = dcUniq dc == getKey trueDataConKey+isFalseDC dc = dcUniq dc == getKey falseDataConKey
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -48,6 +48,44 @@ import qualified Text.Read as Text -- GHC API+#if MIN_VERSION_ghc(9,0,0)+import GHC.Core.Coercion.Axiom+ (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), fromBranches)+import GHC.Core.Coercion (coercionType,coercionKind)+import GHC.Core.FVs (exprSomeFreeVars)+import GHC.Core+ (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..),+ collectArgs, rhssOfAlts, unfoldingTemplate)+import GHC.Core.DataCon+ (DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag,+ dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel)+import GHC.Driver.Session (unsafeGlobalDynFlags)+import GHC.Core.FamInstEnv (FamInst (..), FamInstEnvs, familyInstances)+import GHC.Data.FastString (unpackFS, bytesFS)+import GHC.Types.Id (isDataConId_maybe)+import GHC.Types.Id.Info (IdDetails (..), unfoldingInfo)+import GHC.Types.Literal (Literal (..), LitNumType (..))+import GHC.Unit.Module (moduleName, moduleNameString)+import GHC.Types.Name+ (Name, nameModule_maybe, nameOccName, nameUnique, getSrcSpan)+import GHC.Builtin.Names (tYPETyConKey, integerTyConKey, naturalTyConKey)+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Utils.Outputable (showPpr)+import GHC.Data.Pair (Pair (..))+import GHC.Types.SrcLoc (SrcSpan (..), isGoodSrcSpan)+import GHC.Core.TyCon+ (AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon,+ isFunTyCon, isNewTyCon, isPrimTyCon, isTupleTyCon,+ isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe, tyConArity,+ tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon)+import GHC.Core.Type (mkTvSubstPrs, substTy, coreView)+import GHC.Core.TyCo.Rep (Coercion (..), TyLit (..), Type (..), scaledThing)+import GHC.Types.Unique (Uniquable (..), Unique, getKey, hasKey)+import GHC.Types.Var+ (Id, TyVar, Var, VarBndr (..), idDetails, isTyVar, varName, varType,+ varUnique, idInfo, isGlobalId)+import GHC.Types.Var.Set (isEmptyVarSet)+#else import CoAxiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), fromBranches) import Coercion (coercionType,coercionKind)@@ -110,6 +148,7 @@ import Var (TyVarBndr (..)) #endif import VarSet (isEmptyVarSet)+#endif -- Local imports import Clash.Annotations.Primitive (extractPrim)@@ -364,6 +403,10 @@ go "Clash.Magic.noDeDup" args | [_aTy,f] <- args = C.Tick C.NoDeDup <$> term f+ go "Clash.XException.xToErrorCtx" args+ -- xToErrorCtx :: forall a. String -> a -> a+ | [_ty, _msg, x] <- args+ = term x go nm args | Just n <- parseBundle "bundle" nm -- length args = domain tyvar + signal arg + number of type vars@@ -410,8 +453,9 @@ x' <- coreToIdSP sp x return (x',b') - term' (Case _ _ ty []) = C.TyApp (C.Prim (C.PrimInfo (pack "EmptyCase") C.undefinedTy C.WorkNever))- <$> coreToType ty+ term' (Case _ _ ty []) =+ C.TyApp (C.Prim (C.PrimInfo (pack "EmptyCase") C.undefinedTy C.WorkNever C.SingleResult))+ <$> coreToType ty term' (Case e b ty alts) = do let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (== b)) $ rhssOfAlts alts@@ -435,12 +479,19 @@ -> C.Cast <$> term e <*> coreToType ty1 <*> coreToType ty2 _ -> term e term' (Tick (SourceNote rsp _) e) =+#if MIN_VERSION_ghc(9,0,0)+ C.Tick (C.SrcSpan (RealSrcSpan rsp Nothing)) <$>+ addUsefull (RealSrcSpan rsp Nothing) (term e)+#else C.Tick (C.SrcSpan (RealSrcSpan rsp)) <$> addUsefull (RealSrcSpan rsp) (term e)- term' (Tick _ e) = term e- term' (Type t) = C.TyApp (C.Prim (C.PrimInfo (pack "_TY_") C.undefinedTy C.WorkNever)) <$>- coreToType t- term' (Coercion co) = C.TyApp (C.Prim (C.PrimInfo (pack "_CO_") C.undefinedTy C.WorkNever)) <$>- coreToType (coercionType co)+#endif+ term' (Tick _ e) = term e+ term' (Type t) =+ C.TyApp (C.Prim (C.PrimInfo (pack "_TY_") C.undefinedTy C.WorkNever C.SingleResult))+ <$> coreToType t+ term' (Coercion co) =+ C.TyApp (C.Prim (C.PrimInfo (pack "_CO_") C.undefinedTy C.WorkNever C.SingleResult))+ <$> coreToType (coercionType co) termSP sp = fmap (second unSrcSpanRB) . RWS.listen . addUsefullR sp . term@@ -456,7 +507,10 @@ xType <- coreToType (varType x) case isDataConId_maybe x of Just dc -> case lookupPrim xNameS of- Just p -> return $ C.Prim (C.PrimInfo xNameS xType (maybe C.WorkVariable workInfo p))+ Just p ->+ -- Primitive will be marked MultiResult in Transformations if it+ -- is a multi result primitive.+ return $ C.Prim (C.PrimInfo xNameS xType (maybe C.WorkVariable workInfo p) C.SingleResult) Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc)) then let xInfo = idInfo x unfolding = unfoldingInfo xInfo@@ -491,18 +545,20 @@ -> return (nameModTerm C.SuffixName xType) | f == "Clash.Magic.setName" -> return (nameModTerm C.SetName xType)- | otherwise -> return (C.Prim (C.PrimInfo xNameS xType wi))+ | f == "Clash.XException.xToErrorCtx"+ -> return (xToErrorCtxTerm xType)+ | otherwise -> return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult)) Just (Just (BlackBox {workInfo = wi})) ->- return $ C.Prim (C.PrimInfo xNameS xType wi)+ return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult) Just (Just (BlackBoxHaskell {workInfo = wi})) ->- return $ C.Prim (C.PrimInfo xNameS xType wi)+ return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult) Just Nothing -> -- Was guarded by "DontTranslate". We don't know yet if Clash will -- actually use it later on, so we don't err here.- return $ C.Prim (C.PrimInfo xNameS xType C.WorkVariable)+ return $ C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult) Nothing | x `elem` unlocs- -> return (C.Prim (C.PrimInfo xNameS xType C.WorkVariable))+ -> return (C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult)) | otherwise -> C.Var <$> coreToId x @@ -530,7 +586,11 @@ MachChar c -> C.CharLiteral c #endif #if MIN_VERSION_ghc(8,6,0)+#if MIN_VERSION_ghc(9,0,0)+ LitNumber lt i -> case lt of+#else LitNumber lt i _ -> case lt of+#endif LitNumInteger -> C.IntegerLiteral i LitNumNatural -> C.NaturalLiteral i LitNumInt -> C.IntLiteral i@@ -649,7 +709,11 @@ coreToDataCon :: DataCon -> C2C C.DataCon coreToDataCon dc = do+#if MIN_VERSION_ghc(9,0,0)+ repTys <- mapM (coreToType . scaledThing) (dataConRepArgTys dc)+#else repTys <- mapM coreToType (dataConRepArgTys dc)+#endif dcTy <- coreToType (varType $ dataConWorkId dc) mkDc dcTy repTys where@@ -859,7 +923,11 @@ #endif #if MIN_VERSION_ghc(8,10,0) -- TODO after we drop 8.8: save the distinction between => and ->+#if MIN_VERSION_ghc(9,0,0)+coreToType' (FunTy _ _ ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+#else coreToType' (FunTy _ ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+#endif #else coreToType' (FunTy ty1 ty2) = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2 #endif@@ -1235,7 +1303,7 @@ C.TyLam rTV ( C.TyLam oTV ( C.Lam fId (- (C.App (C.Var fId) (C.Prim (C.PrimInfo rwNm rwTy C.WorkNever))))))+ (C.App (C.Var fId) (C.Prim (C.PrimInfo rwNm rwTy C.WorkNever C.SingleResult)))))) where (C.FunTy fTy _) = C.tyView funTy (C.FunTy rwTy _) = C.tyView fTy@@ -1325,6 +1393,34 @@ xId = C.mkLocalId xTy xName nameModTerm _ ty = error $ $(curLoc) ++ show ty+++-- | Given the type:+--+-- @forall (a :: Type) . String -> a -> a@+--+-- Generate the term:+--+-- @/\(a:Type).\(ctx:String).\(x:a) -> x@+xToErrorCtxTerm+ :: C.Type+ -> C.Term+xToErrorCtxTerm (C.ForAllTy aTV funTy) =+ C.TyLam aTV (+ C.Lam ctxId (+ C.Lam xId (+ C.Var xId)))+ where+ (C.FunTy ctxTy rTy) = C.tyView funTy+ (C.FunTy xTy _) = C.tyView rTy+ -- Safe to use `mkUnsafeSystemName` here, because we're building the+ -- identity \_ x.x, so any shadowing of 'x' would be the desired behavior.+ ctxName = C.mkUnsafeSystemName "ctx" 0+ ctxId = C.mkLocalId ctxTy ctxName+ xName = C.mkUnsafeSystemName "x" 1+ xId = C.mkLocalId xTy xName++xToErrorCtxTerm ty = error $ $(curLoc) ++ show ty isDataConWrapId :: Id -> Bool isDataConWrapId v = case idDetails v of
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -5,7 +5,9 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Clash.GHC.GenerateBindings@@ -27,6 +29,22 @@ import qualified Data.Text as Text import qualified Data.Time.Clock as Clock +import qualified GHC as GHC (Ghc)+#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Types.Basic as GHC+import qualified GHC.Core as GHC+import qualified GHC.Types.Demand as GHC+import qualified GHC.Driver.Session as GHC+import qualified GHC.Types.Id.Info as GHC+import qualified GHC.Utils.Outputable as GHC+import qualified GHC.Types.Name as GHC hiding (varName)+import qualified GHC.Core.TyCon as GHC+import qualified GHC.Core.Type as GHC+import qualified GHC.Builtin.Types as GHC+import qualified GHC.Utils.Misc as GHC+import qualified GHC.Types.Var as GHC+import qualified GHC.Types.SrcLoc as GHC+#else import qualified BasicTypes as GHC import qualified CoreSyn as GHC import qualified Demand as GHC@@ -40,9 +58,11 @@ import qualified Util as GHC import qualified Var as GHC import qualified SrcLoc as GHC+#endif import Clash.Annotations.BitRepresentation.Internal (DataRepr') import Clash.Annotations.Primitive (HDL, extractPrim)+import Clash.Signal.Internal import Clash.Core.Subst (extendGblSubstList, mkSubst, substTm) import Clash.Core.Term (Term (..), mkLams, mkTyLams)@@ -51,10 +71,11 @@ import Clash.Core.TysPrim (tysPrimMap) import Clash.Core.Var (Var (..), Id, IdScope (..), setIdScope) import Clash.Core.VarEnv- (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet, mkVarEnv, unionVarEnv)+ (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet+ ,mkVarEnv, unionVarEnv, elemVarSet, mkVarSet) import Clash.Debug (traceIf) import Clash.Driver (compilePrimitive)-import Clash.Driver.Types (BindingMap, Binding(..))+import Clash.Driver.Types (BindingMap, Binding(..), IsPrim(..)) import Clash.GHC.GHC2Core (C2C, GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm, makeAllTyCons, qualifiedNameString, emptyGHC2CoreState)@@ -76,7 +97,11 @@ indexMaybe (_:xs) n = indexMaybe xs (n-1) generateBindings- :: GHC.OverridingBool+ :: GHC.Ghc ()+ -- ^ Allows us to have some initial action, such as sharing a linker state+ -- See https://github.com/clash-lang/clash-compiler/issues/1686 and+ -- https://mail.haskell.org/pipermail/ghc-devs/2021-March/019605.html+ -> GHC.OverridingBool -- ^ Use color -> [FilePath] -- ^ primitives (blackbox) directories@@ -94,8 +119,9 @@ , [TopEntityT] , CompiledPrimMap -- The primitives found in '.' and 'primDir' , [DataRepr']+ , HashMap.HashMap Text.Text VDomainConfiguration )-generateBindings useColor primDirs importDirs dbs hdl modName dflagsM = do+generateBindings startAction useColor primDirs importDirs dbs hdl modName dflagsM = do ( bindings , clsOps , unlocatable@@ -103,7 +129,8 @@ , topEntities , partitionEithers -> (unresolvedPrims, pFP) , customBitRepresentations- , primGuards ) <- loadModules useColor hdl modName dflagsM importDirs+ , primGuards+ , domainConfs ) <- loadModules startAction useColor hdl modName dflagsM importDirs primMapR <- generatePrimMap unresolvedPrims primGuards (concat [pFP, primDirs, importDirs]) tdir <- maybe ghcLibDir (pure . GHC.topDir) dflagsM startTime <- Clock.getCurrentTime@@ -121,17 +148,16 @@ inScope0 = mkInScopeSet (uniqMapToUniqSet ((mapUniqMap (coerce . bindingId) bindingsMap) `unionUniqMap` (mapUniqMap (coerce . bindingId) clsMap)))- clsMap = mapUniqMap (\(v,i) -> (Binding v GHC.noSrcSpan GHC.Inline (mkClassSelector inScope0 allTcCache (varType v) i))) clsVMap+ clsMap = mapUniqMap (\(v,i) -> (Binding v GHC.noSrcSpan GHC.Inline IsFun (mkClassSelector inScope0 allTcCache (varType v) i))) clsVMap allBindings = bindingsMap `unionVarEnv` clsMap topEntities' =- (\m -> fst (RWS.evalRWS m GHC.noSrcSpan tcMap')) $ mapM (\(topEnt,annM,benchM) -> do+ (\m -> fst (RWS.evalRWS m GHC.noSrcSpan tcMap')) $ mapM (\(topEnt,annM,isTb) -> do topEnt' <- coreToName GHC.varName GHC.varUnique qualifiedNameString topEnt- benchM' <- traverse coreToId benchM- return (topEnt', annM, benchM')) topEntities+ return (topEnt', annM, isTb)) topEntities topEntities'' =- map (\(topEnt, annM, benchM) ->+ map (\(topEnt, annM, isTb) -> case lookupUniqMap topEnt allBindings of- Just b -> TopEntityT (bindingId b) annM benchM+ Just b -> TopEntityT (bindingId b) annM isTb Nothing -> error "This shouldn't happen" ) topEntities' -- Parsing / compiling primitives:@@ -139,14 +165,35 @@ let prepStartDiff = reportTimeDiff prepTime startTime putStrLn $ "Clash: Parsing and compiling primitives took " ++ prepStartDiff - return ( allBindings+ let allBindings' = setNoInlineTopEntities allBindings topEntities''++ return ( allBindings' , allTcCache , tupTcCache , topEntities'' , primMapC , customBitRepresentations+ , domainConfs ) +setNoInlineTopEntities+ :: BindingMap+ -> [TopEntityT]+ -> BindingMap+setNoInlineTopEntities bm tes =+ fmap go bm+ where+ ids = mkVarSet (fmap topId tes)++ go b@Binding{bindingId}+ | bindingId `elemVarSet` ids = b { bindingSpec = GHC.NoInline }+ | otherwise = b++-- TODO This function should be changed to provide the information that+-- Clash.Core.Termination.mkRecInfo provides. To achieve this, it should also+-- be changed to no longer flatten recursive groups (see the documentation for+-- mkRecInfo for an explanation of these).+-- mkBindings :: CompiledPrimMap -> [GHC.CoreBind]@@ -165,19 +212,23 @@ inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v tm <- RWS.local (const 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 tm))]+ return [(v', (Binding v' sp inl pr tm))] 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 (const 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 tm)+ return (Binding v' sp inl pr tm) ) bs case tms of- [Binding v sp inl tm] -> return [(v, Binding v sp inl tm)]+ [Binding v sp inl pr tm] -> return [(v, Binding v sp inl pr tm)] _ -> let vsL = map (setIdScope LocalId . bindingId) tms vsV = map Var vsL subst = extendGblSubstList (mkSubst emptyInScopeSet) (zip vsL vsV)@@ -202,8 +253,8 @@ checkPrimitive :: CompiledPrimMap -> GHC.CoreBndr -> C2C () checkPrimitive primMap v = do nm <- qualifiedNameString (GHC.varName v)- case HashMap.lookup nm primMap of- Just (extractPrim -> Just (BlackBox _ _ _ _ _ _ _ _ _ inc r ri templ)) -> do+ case HashMap.lookup nm primMap >>= extractPrim of+ Just (BlackBox{resultNames, resultInits, template, includes}) -> do let info = GHC.idInfo v inline = GHC.inlinePragmaSpec $ GHC.inlinePragInfo info@@ -214,22 +265,26 @@ nrOfArgs = length argTys loc = case GHC.getSrcLoc v of GHC.UnhelpfulLoc _ -> ""+#if MIN_VERSION_ghc(9,0,0)+ GHC.RealSrcLoc l _ -> showPpr l ++ ": "+#else GHC.RealSrcLoc l -> showPpr l ++ ": "+#endif warnIf cond msg = traceIf cond ("\n"++loc++"Warning: "++msg) return () qName <- Text.unpack <$> qualifiedNameString (GHC.varName v) let primStr = "primitive " ++ qName ++ " "- let usedArgs = concat [ maybe [] getUsedArguments r- , maybe [] getUsedArguments ri- , getUsedArguments templ- , concatMap (getUsedArguments . snd) inc+ let usedArgs = concat [ concatMap getUsedArguments resultNames+ , concatMap getUsedArguments resultInits+ , getUsedArguments template+ , concatMap (getUsedArguments . snd) includes ] let warnArgs [] = return () warnArgs (x:xs) = do warnIf (maybe False GHC.isAbsDmd (indexMaybe dmdArgs x)) ("The Haskell implementation of " ++ primStr ++ "isn't using argument #" ++- show (x+1) ++ ", but the corresponding primitive blackbox does.\n" ++- "This can lead to compile failures because GHC can replace these " +++ show x ++ ", but the corresponding primitive blackbox does.\n" +++ "This can lead to incorrect HDL output because GHC can replace these " ++ "arguments by an undefined value.") warnArgs xs @@ -237,7 +292,11 @@ warnIf (inline /= GHC.NoInline) (primStr ++ "isn't marked NOINLINE." ++ "\nThis might make Clash ignore this primitive.")+#if MIN_VERSION_ghc(9,0,0)+ warnIf (GHC.appIsDeadEnd strictness nrOfArgs)+#else warnIf (GHC.appIsBottom strictness nrOfArgs)+#endif ("The Haskell implementation of " ++ primStr ++ "produces a result that always results in an error.\n" ++ "This can lead to compile failures because GHC can replace entire "
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -24,13 +25,43 @@ import Control.Monad.IO.Class (MonadIO (..)) import qualified Data.ByteString.Lazy.UTF8 as BLU import qualified Data.ByteString.Lazy as BL-import Data.List (elemIndex, foldl', partition)+import Data.Either (partitionEithers)+import Data.List (elemIndex, foldl') import qualified Data.Text as Text-import Data.Maybe (isJust, isNothing,- mapMaybe, catMaybes)+import Data.Maybe (isNothing, mapMaybe, catMaybes) import Data.Word (Word8) -- GHC API+#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Annotations (Annotation(..))+import qualified GHC.Types.Annotations as Annotations+import qualified GHC.Core.Class as Class+import qualified GHC.Core.FVs as CoreFVs+import qualified GHC.Core as CoreSyn+import qualified GHC.Types.Demand as Demand+import GHC.Driver.Session as DynFlags (unsafeGlobalDynFlags)+import qualified GHC+import qualified GHC.Types.Id as Id+import qualified GHC.Types.Id.Info as IdInfo+import qualified GHC.Iface.Syntax as IfaceSyn+import qualified GHC.Iface.Load as LoadIface+import qualified GHC.Data.Maybe as Maybes+import qualified GHC.Core.Make as MkCore+import qualified GHC.Unit.Module as Module+import qualified GHC.Unit.Module.Env as ModuleEnv+import qualified GHC.Utils.Monad as MonadUtils+import qualified GHC.Types.Name as Name+import qualified GHC.Types.Name.Env as NameEnv+import GHC.Utils.Outputable as Outputable (showPpr, showSDoc, text)+import qualified GHC.Plugins as GhcPlugins (deserializeWithData, fromSerialized)+import qualified GHC.IfaceToCore as TcIface+import qualified GHC.Tc.Utils.Monad as TcRnMonad+import qualified GHC.Tc.Types as TcRnTypes+import qualified GHC.Types.Unique.FM as UniqFM+import qualified GHC.Types.Unique.Set as UniqSet+import qualified GHC.Types.Var as Var+import qualified GHC.Unit.Types as UnitTypes+#else import Annotations (Annotation(..), getAnnTargetName_maybe) import qualified Annotations import qualified Class@@ -56,6 +87,7 @@ import qualified UniqFM import qualified UniqSet import qualified Var+#endif -- Internal Modules import Clash.Annotations.BitRepresentation.Internal@@ -67,6 +99,7 @@ import Clash.Primitives.Util (decodeOrErr) import Clash.GHC.GHC2Core (qualifiedNameString') import Clash.Util (curLoc)+import qualified Clash.Util.Interpolate as I -- | Data structure tracking loaded binders (and their related data) data LoadedBinders = LoadedBinders@@ -103,8 +136,13 @@ runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do hscEnv <- GHC.getSession- let localEnv = TcRnTypes.IfLclEnv modName False (text "runIfl") Nothing- Nothing UniqFM.emptyUFM UniqFM.emptyUFM+ let localEnv = TcRnTypes.IfLclEnv modName+#if MIN_VERSION_ghc(9,0,0)+ UnitTypes.NotBoot+#else+ False+#endif+ (text "runIfl") Nothing Nothing UniqFM.emptyUFM UniqFM.emptyUFM let globalEnv = TcRnTypes.IfGblEnv (text "Clash.runIfl") Nothing MonadUtils.liftIO $ TcRnMonad.initTcRnIf 'r' hscEnv globalEnv localEnv action@@ -115,7 +153,11 @@ loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface) loadIface foundMod = do ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface")+#if MIN_VERSION_ghc(9,0,0)+ (fst (Module.getModuleInstantiation foundMod)) foundMod UnitTypes.NotBoot+#else (fst (Module.splitModuleInsts foundMod)) foundMod False+#endif case ifaceFailM of Maybes.Succeeded (modInfo,_) -> return (Just modInfo) Maybes.Failed msg -> let msg' = concat [ $(curLoc)@@ -168,30 +210,39 @@ loadExternalExprs' _hdl loaded visited [] = return (loaded, visited) loadExternalExprs' hdl loaded0 visited0 (e:es) = do- let fvs = CoreFVs.exprSomeFreeVarsList- (\v -> Var.isId v &&- isNothing (Id.isDataConId_maybe v) &&- not (v `UniqSet.elementOfUniqSet` visited0)- ) e-- (clsOps',fvs') = partition (isJust . Id.isClassOpId_maybe) fvs+ let+ isInteresting v =+ Var.isId v+ && not (v `UniqSet.elementOfUniqSet` visited0)+ && isNothing (Id.isDataConId_maybe v) - clsOps'' = map- ( \v -> flip (maybe (error $ $(curLoc) ++ "Not a class op")) (Id.isClassOpId_maybe v) $ \c ->- let clsIds = Class.classAllSelIds c- in maybe (error $ $(curLoc) ++ "Index not found")- (v,)- (elemIndex v clsIds)- ) clsOps'+ fvs0 = CoreFVs.exprSomeFreeVarsList isInteresting e+ fvs1 = map (\v -> maybe (Left v) (Right . (v,)) (Id.isClassOpId_maybe v)) fvs0+ (fvs2, clsOps0) = partitionEithers fvs1+ clsOps1 = map goClsOp clsOps0 - loaded1 <- mergeLoadedBinders <$> mapM (loadExprFromIface hdl) fvs'+ loaded1 <- mergeLoadedBinders <$> mapM (loadExprFromIface hdl) fvs2 loadExternalExprs' hdl- (mergeLoadedBinders [loaded0, loaded1, emptyLb{lbClassOps=clsOps''}])- (foldl' UniqSet.addListToUniqSet visited0 [collectLbBinders loaded1, clsOps'])+ (mergeLoadedBinders [loaded0, loaded1, emptyLb{lbClassOps=clsOps1}])+ (foldl' UniqSet.addListToUniqSet visited0 [collectLbBinders loaded1, map fst clsOps0]) (es ++ map snd (lbBinders loaded1))+ where+ goClsOp :: (Var.Var, GHC.Class) -> (CoreSyn.CoreBndr, Int)+ goClsOp (v, c) =+ case elemIndex v (Class.classAllSelIds c) of+ Nothing -> error [I.i|+ Internal error: couldn't find class-method + #{showPpr DynFlags.unsafeGlobalDynFlags v}++ in class++ #{showPpr DynFlags.unsafeGlobalDynFlags c}+ |]+ Just n -> (v, n)+ loadExprFromIface :: GHC.GhcMonad m => HDL@@ -232,7 +283,12 @@ where env = Annotations.mkAnnEnv anns deserialize = GhcPlugins.deserializeWithData :: [Word8] -> DataReprAnn+#if MIN_VERSION_ghc(9,0,0)+ reprs = let (mEnv,nEnv) = Annotations.deserializeAnns deserialize env+ in ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv+#else reprs = UniqFM.eltsUFM (Annotations.deserializeAnns deserialize env)+#endif filterNameless :: Annotation@@ -324,7 +380,11 @@ dfExpr = MkCore.mkCoreLams dfbndrs dcApp in Left (bndr,dfExpr) CoreSyn.NoUnfolding+#if MIN_VERSION_ghc(9,0,0)+ | Demand.isDeadEndSig $ IdInfo.strictnessInfo _idInfo+#else | Demand.isBottomingSig $ IdInfo.strictnessInfo _idInfo+#endif -> Left ( bndr #if MIN_VERSION_ghc(8,2,2)@@ -338,3 +398,10 @@ ) _ -> Right bndr _ -> Right bndr++#if MIN_VERSION_ghc(9,0,0)+-- | Get the 'name' of an annotation target if it exists.+getAnnTargetName_maybe :: Annotations.AnnTarget name -> Maybe name+getAnnTargetName_maybe (Annotations.NamedTarget nm) = Just nm+getAnnTargetName_maybe _ = Nothing+#endif
src-ghc/Clash/GHC/LoadModules.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}@@ -32,25 +33,37 @@ import Clash.Primitives.Types (UnresolvedPrimitive) import Clash.Util (ClashException(..), pkgIdFromTypeable) import qualified Clash.Util.Interpolate as I-import Control.Arrow (first, second)+import Control.Arrow (first) import Control.DeepSeq (deepseq) import Control.Exception (SomeException, throw) import Control.Monad (forM, when)+import Data.List.Extra (nubSort) #if MIN_VERSION_ghc(8,6,0) import Control.Exception (throwIO) #endif+#if MIN_VERSION_ghc(9,0,0)+import Control.Monad.Catch as MC (try)+#endif import Control.Monad.IO.Class (liftIO) import Data.Char (isDigit) import Data.Generics.Uniplate.DataOnly (transform) import Data.Data (Data)+import Data.Functor ((<&>))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.Typeable (Typeable)-import Data.List (foldl', nub)-import Data.Maybe (catMaybes, listToMaybe, fromMaybe)+import Data.List (foldl', nub, find)+import qualified Data.Map as Map+import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text import qualified Data.Time.Clock as Clock+import qualified Data.Set as Set import Debug.Trace import Language.Haskell.TH.Syntax (lift)+import GHC.Natural (naturalFromInteger) import GHC.Stack (HasCallStack)+import Text.Read (readMaybe) #ifdef USE_GHC_PATHS import GHC.Paths (libdir)@@ -63,9 +76,47 @@ #endif -- GHC API+#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Types.Annotations as Annotations+import qualified GHC.Core.FVs as CoreFVs+import qualified GHC.Core as CoreSyn+import qualified GHC.Core.DataCon as DataCon+import qualified GHC.Data.Graph.Directed as Digraph+import qualified GHC.Runtime.Loader as DynamicLoading+import GHC.Driver.Session (GeneralFlag (..))+import qualified GHC.Driver.Session as DynFlags+import qualified GHC.Data.FastString as FastString+import qualified GHC+import qualified GHC.Driver.Main as HscMain+import qualified GHC.Driver.Types as HscTypes+import qualified GHC.Utils.Monad as MonadUtils+import qualified GHC.Utils.Panic as Panic+import qualified GHC.Serialized as Serialized (deserializeWithData)+import qualified GHC.Unit.Types as UnitTypes (unitIdString)+import qualified GHC.Tc.Utils.Monad as TcRnMonad+import qualified GHC.Tc.Types as TcRnTypes+import qualified GHC.Iface.Tidy as TidyPgm+import qualified GHC.Core.TyCon as TyCon+import qualified GHC.Core.Type as Type+import qualified GHC.Types.Unique as Unique+import qualified GHC.Tc.Instance.Family as FamInst+import qualified GHC.Core.FamInstEnv as FamInstEnv+import qualified GHC.LanguageExtensions as LangExt+import qualified GHC.Types.Name as Name+import qualified GHC.Types.Name.Occurrence as OccName+import GHC.Utils.Outputable (ppr)+import qualified GHC.Utils.Outputable as Outputable+import qualified GHC.Types.Unique.Set as UniqSet+import GHC.Utils.Misc (OverridingBool)+import qualified GHC.Types.Var as Var+import qualified GHC.Driver.Ways as Ways+import qualified GHC.Unit.Module.Env as ModuleEnv+import qualified GHC.Types.Name.Env as NameEnv+#else import qualified Annotations import qualified CoreFVs import qualified CoreSyn+import qualified DataCon import qualified Digraph #if MIN_VERSION_ghc(8,6,0) import qualified DynamicLoading@@ -73,6 +124,7 @@ import DynFlags (GeneralFlag (..)) import qualified DynFlags import qualified Exception+import qualified FastString import qualified GHC import qualified HscMain import qualified HscTypes@@ -82,6 +134,8 @@ import qualified TcRnMonad import qualified TcRnTypes import qualified TidyPgm+import qualified TyCon+import qualified Type import qualified Unique import qualified UniqFM import qualified FamInst@@ -94,6 +148,7 @@ import qualified UniqSet import Util (OverridingBool) import qualified Var+#endif -- Internal Modules import Clash.GHC.GHC2Core (modNameM, qualifiedNameString')@@ -106,6 +161,8 @@ import Clash.Annotations.BitRepresentation.Internal (DataRepr', dataReprAnnToDataRepr') +import Clash.Signal.Internal+ ghcLibDir :: IO FilePath #ifdef USE_GHC_PATHS ghcLibDir = return libdir@@ -150,7 +207,11 @@ , LoadedBinders , [CoreSyn.CoreBind] -- All bindings ) )+#if MIN_VERSION_ghc(9,0,0)+loadExternalModule hdl modName0 = MC.try $ do+#else loadExternalModule hdl modName0 = Exception.gtry $ do+#endif let modName1 = GHC.mkModuleName modName0 foundMod <- GHC.findModule modName1 Nothing let errMsg = "Internal error: found module, but could not load it"@@ -176,7 +237,13 @@ -- Make sure we read the .ghc environment files df <- do df <- GHC.getSessionDynFlags+#if MIN_VERSION_ghc(9,0,0)+ df1 <- liftIO (GHC.interpretPackageEnv df)+ _ <- GHC.setSessionDynFlags df1++#else _ <- GHC.setSessionDynFlags df {DynFlags.pkgDatabase = Nothing}+#endif GHC.getSessionDynFlags #else df <- GHC.getSessionDynFlags@@ -198,7 +265,11 @@ , DynFlags.ghcMode = GHC.CompManager , DynFlags.ghcLink = GHC.LinkInMemory , DynFlags.hscTarget+#if MIN_VERSION_ghc(9,0,0)+ = if Ways.hostIsProfiled+#else = if DynFlags.rtsIsProfiled+#endif then DynFlags.HscNothing else DynFlags.defaultObjectTarget $ #if !MIN_VERSION_ghc(8,10,0)@@ -224,11 +295,15 @@ ]) (return ()) --#if MIN_VERSION_ghc(8,6,0)+#if MIN_VERSION_ghc(9,0,0)+ _ <- GHC.setSessionDynFlags dflags3 hscenv <- GHC.getSession dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3) _ <- GHC.setSessionDynFlags dflags4+#elif MIN_VERSION_ghc(8,6,0)+ hscenv <- GHC.getSession+ dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)+ _ <- GHC.setSessionDynFlags dflags4 #else _ <- GHC.setSessionDynFlags dflags3 #endif@@ -319,8 +394,18 @@ let allBinders = concat binders ++ makeRecursiveGroups (lbBinders loaded0) pure (rootIds, modFamInstEnvs', rootModule, loaded1, allBinders) +nameString :: Name.Name -> String+nameString = OccName.occNameString . Name.nameOccName++varNameString :: Var.Var -> String+varNameString = nameString . Var.varName+ loadModules- :: OverridingBool+ :: GHC.Ghc ()+ -- ^ Allows us to have some initial action, such as sharing a linker state+ -- See https://github.com/clash-lang/clash-compiler/issues/1686 and+ -- https://mail.haskell.org/pipermail/ghc-devs/2021-March/019605.html+ -> OverridingBool -- ^ Use color -> HDL -- ^ HDL target@@ -334,17 +419,17 @@ , [(CoreSyn.CoreBndr,Int)] -- Class operations , [CoreSyn.CoreBndr] -- Unlocatable Expressions , FamInstEnv.FamInstEnvs- , [( CoreSyn.CoreBndr -- topEntity bndr- , Maybe TopEntity -- (maybe) TopEntity annotation- , Maybe CoreSyn.CoreBndr)] -- (maybe) testBench bndr+ , [(CoreSyn.CoreBndr, Maybe TopEntity, Bool)] -- binder + synthesize annotation + is testbench? , [Either UnresolvedPrimitive FilePath] , [DataRepr'] , [(Text.Text, PrimitiveGuard ())]+ , HashMap Text.Text VDomainConfiguration -- domain names to configuration )-loadModules useColor hdl modName dflagsM idirs = do+loadModules startAction useColor hdl modName dflagsM idirs = do libDir <- MonadUtils.liftIO ghcLibDir startTime <- Clock.getCurrentTime GHC.runGhc (Just libDir) $ do+ startAction -- 'mainFunIs' is set to Nothing due to issue #1304: -- https://github.com/clash-lang/clash-compiler/issues/1304 setupGhc useColor ((\d -> d{GHC.mainFunIs=Nothing}) <$> dflagsM) idirs@@ -353,7 +438,7 @@ -- 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).- (rootIds, modFamInstEnvs, rootModule, LoadedBinders{..}, allBinders) <-+ (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@@ -383,57 +468,77 @@ famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs #endif - -- Because tidiedMods is in topological order, binders is also, and hence- -- allSyn is in topological order. This means that the "root" 'topEntity'- -- will be compiled last.- allSyn <- map (second Just) <$> findSynthesizeAnnotations allBinderIds- topSyn <- map (second Just) <$> findSynthesizeAnnotations rootIds- benchAnn <- findTestBenchAnnotations rootIds+ allSyn <- Map.fromList <$> findSynthesizeAnnotations allBinderIds+ topSyn <- map fst <$> findSynthesizeAnnotations rootIds+ benchAnn <- findTestBenches rootIds reprs' <- findCustomReprAnnotations primGuards <- findPrimitiveGuardAnnotations allBinderIds- let topEntityName = fromMaybe "topEntity" (GHC.mainFunIs =<< dflagsM)- varNameString = OccName.occNameString . Name.nameOccName . Var.varName- topEntities = filter ((==topEntityName) . varNameString) rootIds- benches = filter ((== "testBench") . varNameString) rootIds- mergeBench (x,y) = (x,y,lookup x benchAnn)- allSyn' = map mergeBench allSyn+ let+ -- All binders synthesized with Synthesize, all binders annotated with+ -- 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+ <> topSyn - topEntities' <-- case (topEntities, topSyn) of- ([], []) ->- let modName1 = Outputable.showSDocUnsafe (ppr rootModule) in- if topEntityName /= "topEntity" then- Panic.pgmError [I.i|- No top-level function called '#{topEntityName}' found. Did you- forget to export it?- |]- else- Panic.pgmError [I.i|- No top-level function called 'topEntity' found, nor a function with- a 'Synthesize' annotation in module #{modName1}. Did you forget to- export them?+ -- Top entities we wish to synthesize. Users can filter these with -main-is.+ topEntities1 =+ case GHC.mainFunIs =<< dflagsM of+ Just mainIsNm ->+ -- Use requested top entity.+ --+ -- TODO: Look up associated test benches in 'benchAnn'. This would+ -- be wasted effort if implemented right now, as 'getMainTopEntity'+ -- would later remove them again. Functionality of that function+ -- should be moved here.+ --+ -- TODO: Handle fully qualified names to -main-is+ case find ((==mainIsNm) . varNameString) rootIds of+ Nothing ->+ Panic.pgmError [I.i|+ No top-level function called '#{mainIsNm}' found. Did you+ forget to export it?+ |]+ Just top ->+ -- Note that we return /all/ top entities here, even the ones+ -- we don't which to synthesize. 'getMainTopEntity' will later+ -- restrict this to just this top entity (and its dependencies,+ -- which is why we return everything in the first place).+ --+ -- This is quite wasteful though; als Clash will load all+ -- definitions even though it will end up using just a few. TODO+ nubSort (top:allImplicit)+ Nothing ->+ -- User didn't specify anything.+ case allImplicit of+ [] ->+ Panic.pgmError [I.i|+ No top-level function called 'topEntity' or 'testBench' found,+ nor any function annotated with a 'Synthesize' or 'TestBench'+ annotation. If you want to synthesize a specific binder in+ #{show modName}, use '-main-is=myTopEntity'.+ |]+ _ ->+ allImplicit - For more information on 'Synthesize' annotations, check out the- documentation of "Clash.Annotations.TopEntity".- |]- ([], _) ->- return allSyn'- ([x], _) ->- case lookup x topSyn of- Nothing ->- case lookup x benchAnn of- Nothing -> return ((x,Nothing,listToMaybe benches):allSyn')- Just y -> return ((x,Nothing,Just y):allSyn')- Just _ ->- return allSyn'- (_, _) ->- Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found."+ -- Include whether found top entity is a test bench+ allBenchIds = Set.fromList (concat (Map.elems benchAnn))+ topEntities2 = topEntities1 <&> \tid ->+ ( tid+ , tid `Map.lookup` allSyn -- include top entity annotation (if any)+ , tid `Set.member` allBenchIds -- indicate whether top entity is test bench+ ) let reprs1 = lbReprs ++ reprs' annTime <- extTime- `deepseq` length topEntities'+ `deepseq` length topEntities2 `deepseq` lbPrims `deepseq` reprs1 `deepseq` primGuards@@ -442,16 +547,85 @@ let annExtDiff = reportTimeDiff annTime extTime MonadUtils.liftIO $ putStrLn $ "GHC: Parsing annotations took: " ++ annExtDiff + let famInstEnvs' = (fst famInstEnvs, modFamInstEnvs)+ allTCInsts = FamInstEnv.famInstEnvElts (fst famInstEnvs')+ ++ FamInstEnv.famInstEnvElts (snd famInstEnvs')++ knownConfs = filter (\x -> "KnownConf" == nameString (FamInstEnv.fi_fam x)) allTCInsts++#if MIN_VERSION_ghc(8,10,0)+ fsToText = Text.decodeUtf8 . FastString.bytesFS+#else+ fsToText = Text.decodeUtf8 . FastString.fastStringToByteString+#endif++ famToDomain = fromMaybe (error "KnownConf: Expected Symbol at LHS of type family")+ . fmap fsToText . Type.isStrLitTy . head . FamInstEnv.fi_tys+ famToConf = unpackKnownConf . FamInstEnv.fi_rhs++ knownConfNms = fmap famToDomain knownConfs+ knownConfDs = fmap famToConf knownConfs++ knownConfMap = HashMap.fromList (zip knownConfNms knownConfDs)+ return ( allBinders , lbClassOps , lbUnlocatable- , (fst famInstEnvs, modFamInstEnvs)- , topEntities'+ , famInstEnvs'+ , topEntities2 , lbPrims , reprs1 , primGuards+ , knownConfMap ) +-- | Given a type that represents the RHS of a KnownConf type family instance,+-- unpack the fields of the DomainConfiguration and make a VDomainConfiguration.+--+unpackKnownConf :: Type.Type -> VDomainConfiguration+unpackKnownConf ty+ | [d,p,ae,rk,ib,rp] <- Type.tyConAppArgs ty+ -- Domain name+ , Just dom <- fmap FastString.unpackFS (Type.isStrLitTy d)+ -- Period+ , Just period <- fmap naturalFromInteger (Type.isNumLitTy p)+ -- Active Edge+ , aeTc <- Type.tyConAppTyCon ae+ , Just aeDc <- TyCon.isPromotedDataCon_maybe aeTc+ , aeNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName aeDc)+ -- Reset Kind+ , rkTc <- Type.tyConAppTyCon rk+ , Just rkDc <- TyCon.isPromotedDataCon_maybe rkTc+ , rkNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName rkDc)+ -- Init Behavior+ , ibTc <- Type.tyConAppTyCon ib+ , Just ibDc <- TyCon.isPromotedDataCon_maybe ibTc+ , ibNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName ibDc)+ -- Reset Polarity+ , rpTc <- Type.tyConAppTyCon rp+ , Just rpDc <- TyCon.isPromotedDataCon_maybe rpTc+ , rpNm <- OccName.occNameString $ Name.nameOccName (DataCon.dataConName rpDc)+ = VDomainConfiguration dom period+ (asActiveEdge aeNm)+ (asResetKind rkNm)+ (asInitBehavior ibNm)+ (asResetPolarity rpNm)++ | otherwise+ = error $ $(curLoc) ++ "Could not unpack domain configuration."+ where+ asActiveEdge :: HasCallStack => String -> ActiveEdge+ asActiveEdge x = fromMaybe (error $ $(curLoc) ++ "Unknown active edge: " ++ show x) (readMaybe x)++ asResetKind :: HasCallStack => String -> ResetKind+ asResetKind x = fromMaybe (error $ $(curLoc) ++ "Unknown reset kind: " ++ show x) (readMaybe x)++ asInitBehavior :: HasCallStack => String -> InitBehavior+ asInitBehavior x = fromMaybe (error $ $(curLoc) ++ "Unknown init behavior: " ++ show x) (readMaybe x)++ asResetPolarity :: HasCallStack => String -> ResetPolarity+ asResetPolarity x = fromMaybe (error $ $(curLoc) ++ "Unknown reset polarity: " ++ show x) (readMaybe x)+ -- | Given a set of bindings, make explicit non-recursive bindings and -- recursive binding groups. --@@ -520,7 +694,11 @@ => [Annotations.AnnTarget Name.Name] -> m [[a]] findAnnotationsByTargets targets =+#if MIN_VERSION_ghc(9,0,0)+ mapM (GHC.findGlobalAnns Serialized.deserializeWithData) targets+#else mapM (GHC.findGlobalAnns GhcPlugins.deserializeWithData) targets+#endif -- | Find all annotations of a certain type in all modules seen so far. findAllModuleAnnotations@@ -532,8 +710,18 @@ hsc_env <- GHC.getSession ann_env <- liftIO $ HscTypes.prepareAnnotations hsc_env Nothing return $ concat+#if MIN_VERSION_ghc(9,0,0)+ $ (\(mEnv,nEnv) -> ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv)+#else $ UniqFM.nonDetEltsUFM- $ Annotations.deserializeAnns GhcPlugins.deserializeWithData ann_env+#endif+ $ Annotations.deserializeAnns+#if MIN_VERSION_ghc(9,0,0)+ Serialized.deserializeWithData+#else+ GhcPlugins.deserializeWithData+#endif+ ann_env -- | Find all annotations belonging to all binders seen so far. findNamedAnnotations@@ -574,34 +762,64 @@ isSyn (Synthesize {}) = True isSyn _ = False --- | Find testbench annotations and make sure that each binder has no more than--- a single annotation.-findTestBenchAnnotations- :: GHC.GhcMonad m- => [CoreSyn.CoreBndr]- -> m [(CoreSyn.CoreBndr,CoreSyn.CoreBndr)]-findTestBenchAnnotations bndrs = do- anns0 <- findNamedAnnotations bndrs- let anns1 = map (filter isTB) anns0- anns2 = errOnDuplicateAnnotations "TestBench" bndrs anns1- return (map (second findTB) anns2)- where- isTB (TestBench {}) = True- isTB _ = False+-- | Find test bench annotations and return a map tying top entities to their+-- test benches. If there is a binder called @testBench@ _without_ an annotation+-- it assumed to belong to a binder called @topEntity@. If the latter does not+-- exist, the function @testBench@ is left alone.+findTestBenches ::+ GHC.GhcMonad m =>+ -- | Root binders+ [CoreSyn.CoreBndr] ->+ -- | (design under test, associated test benches)+ m (Map.Map CoreSyn.CoreBndr [CoreSyn.CoreBndr])+findTestBenches bndrs0 = do+ anns <- findNamedAnnotations bndrs0+ let+ duts0 = foldl' insertTb Map.empty (concat (zipWith go0 bndrs0 anns))+ duts1 = specialCaseMagicName duts0+ pure duts1+ where+ insertTb m (dut, tb) = Map.insertWith (<>) dut [tb] m+ bndrsMap = HashMap.fromList (map (\x -> (toQualNm x, x)) bndrs0) - findTB :: TopEntity -> CoreSyn.CoreBndr- findTB (TestBench tb) = case listToMaybe (filter (eqNm tb) bndrs) of- Just tb' -> tb'- Nothing -> Panic.pgmError $- "TestBench named: " ++ show tb ++ " not found"- findTB _ = Panic.pgmError "Unexpected Synthesize"+ -- Special case magic name 'testBench'. See function documentation.+ specialCaseMagicName m =+ let+ topEntM = find ((=="topEntity") . varNameString) bndrs0+ tbM = find ((=="testBench") . varNameString) bndrs0+ in+ case (topEntM, tbM) of+ (Just dut, Just tb) -> insertTb m (dut, tb)+ _ -> m - eqNm thNm bndr = Text.pack (show thNm) == qualNm- where- bndrNm = Var.varName bndr- qualNm = maybe occName (\modName -> modName `Text.append` ('.' `Text.cons` occName)) (modNameM bndrNm)- occName = Text.pack (OccName.occNameString (Name.nameOccName bndrNm))+ -- go0 + go1: map over all annotations; look for test bench annotations and+ -- tie them to top entities indicated in the annotation.+ go0 bndr anns = mapMaybe (go1 bndr) anns+ go1 tbBndr (TestBench dutNm) =+ case HashMap.lookup (Text.pack (show dutNm)) bndrsMap of+ Nothing ->+ Panic.pgmError [I.i|+ Could not find design under test #{show (show dutNm)}, associated with+ test bench #{show (toQualNm tbBndr)}. Note that testbenches should be+ exported from the same module as the design under test.+ |]+ Just dutBndr ->+ Just (dutBndr, tbBndr)+ go1 _ _ = Nothing +-- | Create a fully qualified name from a var, excluding package. Example+-- output: @Clash.Sized.Internal.BitVector.low@.+toQualNm :: Var.Var -> Text.Text+toQualNm bndr =+ let+ bndrNm = Var.varName bndr+ occName = Text.pack (OccName.occNameString (Name.nameOccName bndrNm))+ in+ maybe+ occName+ (\modName -> modName `Text.append` ('.' `Text.cons` occName))+ (modNameM bndrNm)+ -- | Find primitive annotations bound to given binders, or annotations made -- in modules of those binders. findPrimitiveAnnotations@@ -710,8 +928,9 @@ setWantedLanguageExtensions df = foldl' DynFlags.gopt_set (foldl' DynFlags.xopt_unset- (foldl' DynFlags.xopt_set df wantedLanguageExtensions) unwantedLanguageExtensions)- wantedOptimizations+ (foldl' DynFlags.xopt_set df wantedLanguageExtensions)+ unwantedLanguageExtensions)+ wantedOptimizations where wantedOptimizations = [ Opt_CSE -- CSE@@ -777,7 +996,9 @@ ,GHC.con_args = rmConDetails (GHC.con_args gadt) } rmCD h98@(GHC.ConDeclH98 {}) = h98 {GHC.con_args = rmConDetails (GHC.con_args h98)}+#if !MIN_VERSION_ghc(9,0,0) rmCD xcon = xcon+#endif #else rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_type = rmSigType (GHC.con_type gadt)} rmCD h98@(GHC.ConDeclH98 {}) = h98 {GHC.con_details = rmConDetails (GHC.con_details h98)}@@ -790,11 +1011,17 @@ #endif -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name])- -- rmConDetails :: GHC.DataId name => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name+ -- rmConDetails :: _ => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name+#if MIN_VERSION_ghc(9,0,0)+ rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsScaledType args)+ rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmHsScaledType l) (rmHsScaledType r)+#else rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsType args)- rmConDetails (GHC.RecCon rec) = GHC.RecCon ((fmap . fmap . fmap) rmConDeclF rec) rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmHsType l) (rmHsType r)+#endif+ rmConDetails (GHC.RecCon rec) = GHC.RecCon ((fmap . fmap . fmap) rmConDeclF rec) + -- rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name) rmHsType = transform go where@@ -805,6 +1032,13 @@ #endif go ty = ty +#if MIN_VERSION_ghc(9,0,0)+ rmHsScaledType = transform go+ where+ go (GHC.HsScaled m (GHC.unLoc -> GHC.HsBangTy _ _ ty)) = GHC.HsScaled m ty+ go ty = ty+#endif+ -- rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name rmConDeclF cdf = cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)} @@ -822,7 +1056,11 @@ (x:_) -> throw (ClashException noSrcSpan (msgWrongPrelude x) Nothing) where pkgs = HscTypes.dep_pkgs . HscTypes.mg_deps $ guts+#if MIN_VERSION_ghc(9,0,0)+ pkgIds = map (UnitTypes.unitIdString . fst) pkgs+#else pkgIds = map (GhcPlugins.installedUnitIdString . fst) pkgs+#endif prelude = "clash-prelude-" isPrelude pkg = case splitAt (length prelude) pkg of (x,y:_) | x == prelude && isDigit y -> True -- check for a digit so we don't match clash-prelude-extras
src-ghc/Clash/GHC/NetlistTypes.hs view
@@ -5,6 +5,7 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -99,8 +100,13 @@ _ -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments" _ -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs" else returnN (Unsigned 64)+#if MIN_VERSION_ghc(9,0,0)+ "GHC.Num.Integer.Integer" -> returnN (Signed iw)+ "GHC.Num.Natural.Natural" -> returnN (Unsigned iw)+#else "GHC.Integer.Type.Integer" -> returnN (Signed iw) "GHC.Natural.Natural" -> returnN (Unsigned iw)+#endif "GHC.Prim.Char#" -> returnN (Unsigned 21) "GHC.Prim.Int#" -> returnN (Signed iw) "GHC.Prim.Word#" -> returnN (Unsigned iw)@@ -175,6 +181,12 @@ -> do tag1 <- domTag m tag0 returnN (Reset (pack tag1))++ "Clash.Signal.Internal.Enable"+ | [tag0] <- args+ -> do+ tag1 <- domTag m tag0+ returnN (Enable (pack tag1)) "Clash.Sized.Internal.BitVector.Bit" -> returnN Bit
+ src-ghc/Clash/GHC/PartialEval.hs view
@@ -0,0 +1,24 @@+{-|+Copyright : (C) 2020, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++The partial evalautor for the GHC front-end. This can be used to evaluate+terms in Clash core to WHNF or NF, using knowledge of GHC primitives and types.+For functions which can use this evaluator, see Clash.Core.PartialEval.+-}++module Clash.GHC.PartialEval where++import Clash.Core.PartialEval++import Clash.GHC.PartialEval.Eval+import Clash.GHC.PartialEval.Quote++-- | The partial evaluator for the GHC front-end. For more details about the+-- implementation see Clash.GHC.PartialEval.Eval for evaluation to WHNF and+-- Clash.GHC.PartialEval.Quote for quoting to NF.+--+ghcEvaluator :: Evaluator+ghcEvaluator = Evaluator eval quote+
+ src-ghc/Clash/GHC/PartialEval/Eval.hs view
@@ -0,0 +1,620 @@+{-|+Copyright : (C) 2020, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++This module provides the "evaluation" part of the partial evaluator. This+is implemented in the classic "eval/apply" style, with a variant of apply for+performing type applications.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.GHC.PartialEval.Eval+ ( eval+ , apply+ , applyTy+ ) where++import Control.Monad (foldM)+import Data.Bifunctor+import Data.Bitraversable+import Data.Either+import Data.Graph (SCC(..))+import Data.Primitive.ByteArray (ByteArray(..))+#if MIN_VERSION_base(4,15,0)+import GHC.Num.Integer (Integer (..))+#else+import GHC.Integer.GMP.Internals (BigNat(..), Integer(..))+#endif++#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Basic (InlineSpec(..))+#else+import BasicTypes (InlineSpec(..))+#endif++import Clash.Core.DataCon (DataCon(..))+import Clash.Core.Literal (Literal(..))+import Clash.Core.PartialEval.AsTerm+import Clash.Core.PartialEval.Monad+import Clash.Core.PartialEval.NormalForm+import Clash.Core.Subst (substTy)+import Clash.Core.Term+import Clash.Core.TermInfo+import Clash.Core.TyCon (tyConDataCons)+import Clash.Core.Type+import Clash.Core.TysPrim (integerPrimTy)+import qualified Clash.Core.Util as Util+import Clash.Core.Var+import Clash.Driver.Types (Binding(..), IsPrim(..))+import Clash.Unique (lookupUniqMap')++-- | Evaluate a term to WHNF.+--+eval :: Term -> Eval Value+eval = \case+ Var i -> evalVar i+ Literal lit -> pure (VLiteral lit)+ Data dc -> evalData dc+ Prim pr -> evalPrim pr+ Lam i x -> evalLam i x+ TyLam i x -> evalTyLam i x+ App x y -> evalApp x (Left y)+ TyApp x ty -> evalApp x (Right ty)+ Letrec bs x -> evalLetrec bs x+ Case x ty alts -> evalCase x ty alts+ Cast x a b -> evalCast x a b+ Tick tick x -> evalTick tick x++delayEval :: Term -> Eval Value+delayEval = \case+ Literal lit -> pure (VLiteral lit)+ Lam i x -> evalLam i x+ TyLam i x -> evalTyLam i x+ Tick t x -> flip VTick t <$> delayEval x+ term -> VThunk term <$> getLocalEnv++forceEval :: Value -> Eval Value+forceEval = forceEvalWith [] []++forceEvalWith :: [(TyVar, Type)] -> [(Id, Value)] -> Value -> Eval Value+forceEvalWith tvs ids = \case+ VThunk term env -> do+ tvs' <- traverse (traverse evalType) tvs+ setLocalEnv env (withTyVars tvs' . withIds ids $ eval term)++ value -> pure value++delayArg :: Arg Term -> Eval (Arg Value)+delayArg = bitraverse delayEval evalType++delayArgs :: Args Term -> Eval (Args Value)+delayArgs = traverse delayArg++evalType :: Type -> Eval Type+evalType ty = do+ tcm <- getTyConMap+ subst <- getTvSubst++ pure (normalizeType tcm (substTy subst ty))++evalVar :: Id -> Eval Value+evalVar i+ | isLocalId i = lookupLocal i+ | otherwise = lookupGlobal i++lookupLocal :: Id -> Eval Value+lookupLocal i = do+ var <- findId i+ varTy <- evalType (varType i)+ let i' = i { varType = varTy }++ case var of+ Just x -> do+ workFree <- workFreeValue x+ if workFree then forceEval x else pure (VNeutral (NeVar i'))++ Nothing -> pure (VNeutral (NeVar i'))++lookupGlobal :: Id -> Eval Value+lookupGlobal i = do+ -- inScope <- getInScope+ fuel <- getFuel+ var <- findBinding i++ case var of+ Just x+ -- The binding cannot be inlined. Note that this is limited to bindings+ -- which are not primitives in Clash, as these must be marked NOINLINE.+ | bindingSpec x == NoInline+ , bindingIsPrim x == IsFun+ -> pure (VNeutral (NeVar i))++ -- There is no fuel, meaning no more inlining can occur.+ | fuel == 0+ -> pure (VNeutral (NeVar i))++ -- Inlining can occur, using one unit of fuel in the process.+ | otherwise+ -> withContext i . withFuel $ do+ val <- forceEval (bindingTerm x)+ replaceBinding (x { bindingTerm = val })+ pure val++ Nothing+ -> pure (VNeutral (NeVar i))++evalData :: DataCon -> Eval Value+evalData dc+ | fullyApplied (dcType dc) [] =+ VData dc [] <$> getLocalEnv++ | otherwise =+ etaExpand (Data dc) >>= eval++evalPrim :: PrimInfo -> Eval Value+evalPrim pr+ | fullyApplied (primType pr) [] =+ evalPrimOp pr []++ | otherwise =+ etaExpand (Prim pr) >>= eval++-- TODO Hook up to primitive evaluation skeleton+evalPrimOp :: PrimInfo -> Args Value -> Eval Value+evalPrimOp pr args = pure (VNeutral (NePrim pr args))++fullyApplied :: Type -> Args a -> Bool+fullyApplied ty args =+ length (fst $ splitFunForallTy ty) == length args++etaExpand :: Term -> Eval Term+etaExpand term = do+ tcm <- getTyConMap++ case collectArgs term of+ x@(Data dc, _) -> expand tcm (dcType dc) x+ x@(Prim pr, _) -> expand tcm (primType pr) x+ _ -> pure term+ where+ etaNameOf =+ either (pure . Right) (fmap Left . getUniqueId "eta")++ expand tcm ty (tm, args) = do+ let (missingTys, _) = splitFunForallTy (applyTypeToArgs tm tcm ty args)+ missingArgs <- traverse etaNameOf missingTys++ pure $ mkAbstraction+ (mkApps term (fmap (bimap Var VarTy) missingArgs))+ missingArgs++evalLam :: Id -> Term -> Eval Value+evalLam i x = do+ varTy <- evalType (varType i)+ let i' = i { varType = varTy }+ env <- getLocalEnv++ pure (VLam i' x env)++evalTyLam :: TyVar -> Term -> Eval Value+evalTyLam i x = do+ varTy <- evalType (varType i)+ let i' = i { varType = varTy }+ env <- getLocalEnv++ pure (VTyLam i' x env)++evalApp :: Term -> Arg Term -> Eval Value+evalApp x y+ | Data dc <- f+ = if fullyApplied (dcType dc) args+ then do+ argThunks <- delayArgs args+ VData dc argThunks <$> getLocalEnv++ else etaExpand term >>= eval++ | Prim pr <- f+ , prArgs <- fst $ splitFunForallTy (primType pr)+ , numArgs <- length prArgs+ = case compare (length args) numArgs of+ LT ->+ etaExpand term >>= eval++ EQ -> do+ argThunks <- delayArgs args+ let tyVars = lefts prArgs+ tyArgs = rights args++ withTyVars (zip tyVars tyArgs) (evalPrimOp pr argThunks)++ GT -> do+ let (pArgs, rArgs) = splitAt numArgs args+ pArgThunks <- delayArgs pArgs+ primRes <- evalPrimOp pr pArgThunks+ rArgThunks <- delayArgs rArgs++ foldM applyArg primRes rArgThunks++ | otherwise+ = preserveFuel $ do+ evalF <- eval f+ argThunks <- delayArgs args+ foldM applyArg evalF argThunks+ where+ term = either (App x) (TyApp x) y+ (f, args, _ticks) = collectArgsTicks term++evalLetrec :: [LetBinding] -> Term -> Eval Value+evalLetrec bs x = do+ -- Determine if a binding should be kept in a letrec or inlined. We keep+ -- bindings which perform work to prevent duplication of registers etc.+ (keep, inline) <- foldM evalScc ([], []) (Util.sccLetBindings bs)+ eX <- withIds (keep <> inline) (eval x)++ case keep of+ [] -> pure eX+ _ -> pure (VNeutral (NeLetrec keep eX))+ where+ evalBind (i, y) = do+ iTy <- evalType (varType i)+ eY <- delayEval y++ pure (i { varType = iTy }, eY)++ evalScc (k, i) = \case+ AcyclicSCC y -> do+ eY <- evalBind y+ workFree <- workFreeValue (snd eY)++ if workFree then pure (k, eY:i) else pure (eY:k, i)++ CyclicSCC ys -> do+ eYs <- traverse evalBind ys+ pure (eYs <> k, i)++evalCase :: Term -> Type -> [Alt] -> Eval Value+evalCase term ty as = do+ subject <- delayEval term+ resTy <- evalType ty+ alts <- delayAlts as++ caseCon subject resTy alts++-- | Attempt to apply the case-of-known-constructor transformation on a case+-- expression. If no suitable alternative can be chosen, attempt to transform+-- the case expression to try and expose more opportunities.+--+caseCon :: Value -> Type -> [(Pat, Value)] -> Eval Value+caseCon subject ty alts = do+ forcedSubject <- keepLifted (forceEval subject)++ -- If the subject is undefined, the whole expression is undefined.+ case isUndefined forcedSubject of+ True -> eval (Util.undefinedTm ty)+ False ->+ case stripValue forcedSubject of+ -- Known literal: attempt to match or throw an error.+ VLiteral lit -> do+ let def = error ("caseCon: No pattern matched " <> show lit <> " in " <> show alts)+ match <- findBestAlt (matchLiteral lit) alts+ evalAlt def match++ -- Known data constructor: attempt to match or throw an error.+ -- The environment here is the same as the current environment.+ VData dc args _env -> do+ let def = error ("caseCon: No pattern matched " <> show dc <> " in " <> show alts)+ match <- findBestAlt (matchData dc args) alts+ evalAlt def match++ -- Neutral primitives may be clash primitives which are treated as+ -- values, like fromInteger# for various types in clash-prelude.+ VNeutral (NePrim pr args) -> do+ let def = VNeutral (NeCase forcedSubject ty alts)+ match <- findBestAlt (matchClashPrim pr args) alts+ evalAlt def match++ -- We know nothing: attempt case-of-case / case-of-let.+ _ -> tryTransformCase forcedSubject ty alts++-- | Attempt to apply a transformation to a case expression to expose more+-- opportunities for caseCon. If no transformations can be applied the+-- case expression can only be neutral.+--+tryTransformCase :: Value -> Type -> [(Pat, Value)] -> Eval Value+tryTransformCase subject ty alts =+ case stripValue subject of+ -- A case of case: pull out the inner case expression if possible and+ -- attempt caseCon on the new case expression.+ VNeutral (NeCase innerSubject _ innerAlts) -> do+ forcedAlts <- forceAlts innerAlts++ if all (isKnown . snd) forcedAlts+ then let asCase v = VNeutral (NeCase v ty alts)+ newAlts = second asCase <$> innerAlts+ in caseCon innerSubject ty newAlts++ else pure (VNeutral (NeCase subject ty alts))++ -- A case of let: Pull out the let expression if possible and attempt+ -- caseCon on the new case expression.+ VNeutral (NeLetrec bindings innerSubject) -> do+ newCase <- caseCon innerSubject ty alts+ pure (VNeutral (NeLetrec bindings newCase))++ -- There is no way to continue evaluating the case, do nothing.+ -- TODO elimExistentials here.+ _ -> pure (VNeutral (NeCase subject ty alts))+ where+ -- We only care about case of case if alternatives of the inner case+ -- expression correspond to something we can do caseCon on.+ --+ -- TODO We may also care if it is another case of case?+ --+ isKnown = \case+ VNeutral (NePrim pr _) ->+ primName pr `elem`+ [ "Clash.Sized.Internal.BitVector.fromInteger##"+ , "Clash.Sized.Internal.BitVector.fromInteger#"+ , "Clash.Sized.Internal.Index.fromInteger#"+ , "Clash.Sized.Internal.Signed.fromInteger#"+ , "Clash.Sized.Internal.Unsigned.fromInteger#"+ ]++ VLiteral{} -> True+ VData{} -> True+ _ -> False++delayAlts :: [Alt] -> Eval [(Pat, Value)]+delayAlts = traverse (bitraverse delayPat delayEval)+ where+ delayPat = \case+ DataPat dc tvs ids -> do+ tvsTys <- traverse evalType (fmap varType tvs)+ idsTys <- traverse evalType (fmap varType ids)++ let setTy v ty = v { varType = ty }+ tvs' = zipWith setTy tvs tvsTys+ ids' = zipWith setTy ids idsTys++ pure (DataPat dc tvs' ids')++ pat -> pure pat++forceAlts :: [(Pat, Value)] -> Eval [(Pat, Value)]+forceAlts = traverse (traverse forceEval)++data PatResult+ = Match (Pat, Value) [(TyVar, Type)] [(Id, Value)]+ | NoMatch++evalAlt :: Value -> PatResult -> Eval Value+evalAlt def = \case+ Match (_, val) tvs ids ->+ forceEvalWith tvs ids val++ NoMatch -> pure def++matchLiteral :: Literal -> (Pat, Value) -> Eval PatResult+matchLiteral lit alt@(pat, _) =+ case pat of+ DataPat dc [] [i]+ | IntegerLiteral n <- lit+ -> case n of+#if MIN_VERSION_base(4,15,0)+ IS _+#else+ S# _+#endif+ | dcTag dc == 1 -> pure $ Match alt [] [(i, VLiteral (IntLiteral n))]++#if MIN_VERSION_base(4,15,0)+ IP bn+#else+ Jp# bn+#endif+ | dcTag dc == 2 -> matchBigNat i bn++#if MIN_VERSION_base(4,15,0)+ IN bn+#else+ Jn# bn+#endif+ | dcTag dc == 3 -> matchBigNat i bn++ _ -> pure NoMatch++ | NaturalLiteral n <- lit+ -> case n of+#if MIN_VERSION_base(4,15,0)+ IS _+#else+ S# _+#endif+ | dcTag dc == 1 -> pure $ Match alt [] [(i, VLiteral (WordLiteral n))]++#if MIN_VERSION_base(4,15,0)+ IP bn+#else+ Jp# bn+#endif+ | dcTag dc == 2 -> matchBigNat i bn++ _ -> pure NoMatch++ LitPat n+ | lit == n -> pure $ Match alt [] []++ DefaultPat -> pure $ Match alt [] []++ _ -> pure NoMatch+ where+ -- Somewhat of a hack: We find the constructor for BigNat and apply a+ -- ByteArray literal made from the given ByteArray to it.+#if MIN_VERSION_base(4,15,0)+ matchBigNat i ba = do+#else+ matchBigNat i (BN# ba) = do+#endif+ tcm <- getTyConMap+ let Just integerTcName = fmap fst (splitTyConAppM integerPrimTy)+ [_, jpDc, _] = tyConDataCons (lookupUniqMap' tcm integerTcName)+ ([bnTy], _) = splitFunTys tcm (dcType jpDc)+ Just bnTcName = fmap fst (splitTyConAppM bnTy)+ [bnDc] = tyConDataCons (lookupUniqMap' tcm bnTcName)++ let arr = ByteArrayLiteral (ByteArray ba)+ val <- VData bnDc [Left (VLiteral arr)] <$> getLocalEnv++ pure (Match alt [] [(i, val)])++matchData :: DataCon -> Args Value -> (Pat, Value) -> Eval PatResult+matchData dc args alt@(pat, _) =+ case pat of+ DataPat c tvs ids+ | dc == c+ -> do let (tms, tys) = bimap (zip ids) (zip tvs) (partitionEithers args)+ pure (Match alt tys tms)++ DefaultPat -> pure (Match alt [] [])+ _ -> pure NoMatch++-- TODO Should this also consider DataPat and data constructors?+-- The old evaluator did not, but matchData wouldn't cover it.+--+matchClashPrim :: PrimInfo -> Args Value -> (Pat, Value) -> Eval PatResult+matchClashPrim pr args alt@(pat, _) =+ case pat of+ LitPat lit+ -- Bit literals+ | primName pr == "Clash.Sized.BitVector.fromInteger##"+ , [Left mask, Left val] <- args+ -> do VLiteral (WordLiteral m) <- forceEval mask+ VLiteral l <- forceEval val++ if m == 0 && l == lit+ then pure (Match alt [] [])+ else pure NoMatch++ -- BitVector literals+ | primName pr == "Clash.Sized.BitVector.fromInteger#"+ , [Right _n, Left _knN, Left mask, Left val] <- args+ -> do VLiteral (NaturalLiteral m) <- forceEval mask+ VLiteral l <- forceEval val++ if m == 0 && l == lit+ then pure (Match alt [] [])+ else pure NoMatch++ -- Sized integer / natural literals+ | primName pr `elem` clashSizedNumbers+ , [Right _n, Left _knN, Left val] <- args+ -> do VLiteral l <- forceEval val++ if l == lit+ then pure (Match alt [] [])+ else pure NoMatch++ -- The primitive is not a literal from clash-prelude+ _ -> pure NoMatch+ where+ clashSizedNumbers =+ [ "Clash.Sized.Internal.Index.fromInteger#"+ , "Clash.Sized.Internal.Signed.fromInteger#"+ , "Clash.Sized.Internal.Unsigned.fromInteger#"+ ]++-- | Given a predicate to check if an alternative is a match, find the best+-- alternative that matches the predicate. Best is defined as being the most+-- specific matching pattern (meaning DefaultPat is only used if no other+-- pattern tried matches).+--+findBestAlt+ :: ((Pat, Value) -> Eval PatResult)+ -> [(Pat, Value)]+ -> Eval PatResult+findBestAlt checkAlt =+ go NoMatch+ where+ go !acc [] = pure acc+ go !acc (a:as) = do+ match <- checkAlt a+ case match of+ Match (pat, _term) _tvs _ids+ | pat == DefaultPat -> go match as+ | otherwise -> pure match++ NoMatch -> go acc as++evalCast :: Term -> Type -> Type -> Eval Value+evalCast x a b = VCast <$> eval x <*> evalType a <*> evalType b++evalTick :: TickInfo -> Term -> Eval Value+evalTick tick x = VTick <$> eval x <*> pure tick++applyArg :: Value -> Arg Value -> Eval Value+applyArg val =+ either (apply val) (applyTy val)++apply :: Value -> Value -> Eval Value+apply val arg = do+ tcm <- getTyConMap+ forced <- forceEval val+ canApply <- workFreeValue arg++ case stripValue forced of+ -- If the LHS of application evaluates to a letrec, then add any bindings+ -- that do work to this letrec instead of creating a new one.+ VNeutral (NeLetrec bs x)+ | canApply -> do+ inner <- apply x arg+ pure (VNeutral (NeLetrec bs inner))++ | otherwise -> do+ varTy <- evalType (valueType tcm arg)+ var <- getUniqueId "workArg" varTy+ inner <- apply x (VNeutral (NeVar var))+ pure (VNeutral (NeLetrec ((var, arg) : bs) inner))++ -- If the LHS of application is neutral, make a letrec around the neutral+ -- application if the argument performs work.+ VNeutral neu+ | canApply -> pure (VNeutral (NeApp neu arg))+ | otherwise -> do+ varTy <- evalType (valueType tcm arg)+ var <- getUniqueId "workArg" varTy+ let inner = VNeutral (NeApp neu (VNeutral (NeVar var)))+ pure (VNeutral (NeLetrec [(var, arg)] inner))++ -- If the LHS of application is a lambda, make a letrec with the name of+ -- the argument around the result of evaluation if it performs work.+ VLam i x env+ | canApply -> setLocalEnv env $ withId i arg (eval x)+ | otherwise -> setLocalEnv env $ do+ inner <- withId i arg (eval x)+ pure (VNeutral (NeLetrec [(i, arg)] inner))++ f ->+ error ("apply: Cannot apply " <> show arg <> " to " <> show f)+ where+ -- Somewhat of a cheat, but very quick to implement.+ valueType tcm = termType tcm . asTerm++applyTy :: Value -> Type -> Eval Value+applyTy val ty = do+ forcedVal <- forceEval val+ argTy <- evalType ty++ case stripValue forcedVal of+ VNeutral n ->+ pure (VNeutral (NeTyApp n argTy))++ VTyLam i x env ->+ setLocalEnv env $ withTyVar i argTy (eval x)++ f ->+ error ("applyTy: Cannot apply " <> show argTy <> " to " <> show f)
+ src-ghc/Clash/GHC/PartialEval/Primitive.hs view
@@ -0,0 +1,57 @@+{-|+Copyright : (C) 2020, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Evaluation of primitive operations in the partial evaluator. This is used+by the Clash.GHC.PartialEval.Eval module to implement fully applied primitives.+-}++module Clash.GHC.PartialEval.Primitive+ ( evalPrimitive+ ) where++import Clash.Core.PartialEval.Monad+import Clash.Core.PartialEval.NormalForm+import Clash.Core.Term (Term, PrimInfo)++-- | Evaluate a primitive with the given arguments.+-- See NOTE [Evaluating primitives] for more information.+--+evalPrimitive+ :: (Term -> Eval Value)+ -- ^ Evaluation function for forcing arguments+ -> PrimInfo+ -- ^ The primitive to evaluate+ -> Args Value+ -- ^ The arguments supplied to the primitive+ -> Eval Value+ -- ^ The result of evaluating the primitive+evalPrimitive _eval pr args =+ -- TODO Implement evaluation of primitives.+ pure (VNeutral (NePrim pr args))++{-+NOTE [Evaluating primitives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the evaluator encounters a primitive operation with all arguments applied,+it will attempt to evaluate it. If this is possible, the call to the primitive+will be replaced with the result. However, it may not be possible to evaluate+a primitive if not all arguments are statically known (i.e. if an argument is+a variable with an unknown value). In this case, a neutral primitive is+returned instead.++Some primitives do not evaluate, and are deliberately preserved in the result+of the evaluator as neutral primitives. Notable examples of this are++ * GHC.CString.unpackCString#+ * Clash.Sized.Internal.BitVector.fromInteger##+ * Clash.Sized.Internal.BitVector.fromInteger#+ * Clash.Sized.Internal.Index.fromInteger#+ * Clash.Sized.Internal.Signed.fromInteger#+ * Clash.Sized.Internal.Unsigned.fromInteger#++Some primitives may throw exceptions (such as division by zero) or need to+perform IO (e.g. primitives on ByteArray#). These effects are supported by the+Eval monad, see Clash.Core.PartialEval.Monad.+-}
+ src-ghc/Clash/GHC/PartialEval/Quote.hs view
@@ -0,0 +1,99 @@+{-|+Copyright : (C) 2020, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++This module provides the "quoting" part of the partial evaluator, which+traverses a WHNF value, recursively evaluating sub-terms to remove redexes.+-}++{-# LANGUAGE LambdaCase #-}++module Clash.GHC.PartialEval.Quote+ ( quote+ ) where++import Data.Bitraversable++import Clash.Core.DataCon (DataCon)+import Clash.Core.PartialEval.Monad+import Clash.Core.PartialEval.NormalForm+import Clash.Core.Term (Term, PrimInfo, TickInfo, Pat)+import Clash.Core.Type (Type(VarTy))+import Clash.Core.Var (Id, TyVar)++import Clash.GHC.PartialEval.Eval++quote :: Value -> Eval Normal+quote = \case+ VNeutral n -> NNeutral <$> quoteNeutral n+ VLiteral l -> pure (NLiteral l)+ VData dc args env -> quoteData dc args env+ VLam i x env -> quoteLam i x env+ VTyLam i x env -> quoteTyLam i x env+ VCast x a b -> quoteCast x a b+ VTick x tick -> quoteTick x tick+ VThunk x env -> quoteThunk x env++quoteNeutral :: Neutral Value -> Eval (Neutral Normal)+quoteNeutral = \case+ NeVar i -> pure (NeVar i)+ NePrim pr args -> quoteNePrim pr args+ NeApp x y -> quoteNeApp x y+ NeTyApp x ty -> quoteNeTyApp x ty+ NeLetrec bs x -> quoteNeLetrec bs x+ NeCase x ty alts -> quoteNeCase x ty alts++quoteArgs :: Args Value -> Eval (Args Normal)+quoteArgs = traverse (bitraverse quote pure)++quoteAlts :: [(Pat, Value)] -> Eval [(Pat, Normal)]+quoteAlts = traverse (bitraverse pure quote)++quoteBinders :: [(Id, Value)] -> Eval [(Id, Normal)]+quoteBinders = traverse (bitraverse pure quote)++quoteData :: DataCon -> Args Value -> LocalEnv -> Eval Normal+quoteData dc args env = setLocalEnv env (NData dc <$> quoteArgs args)++quoteLam :: Id -> Term -> LocalEnv -> Eval Normal+quoteLam i x env =+ setLocalEnv env $ do+ eX <- apply (VLam i x env) (VNeutral (NeVar i))+ qX <- quote eX++ pure (NLam i qX env)++quoteTyLam :: TyVar -> Term -> LocalEnv -> Eval Normal+quoteTyLam i x env =+ setLocalEnv env $ do+ eX <- applyTy (VTyLam i x env) (VarTy i)+ qX <- quote eX++ pure (NTyLam i qX env)++quoteCast :: Value -> Type -> Type -> Eval Normal+quoteCast x a b = NCast <$> quote x <*> pure a <*> pure b++quoteTick :: Value -> TickInfo -> Eval Normal+quoteTick x tick = NTick <$> quote x <*> pure tick++quoteThunk :: Term -> LocalEnv -> Eval Normal+quoteThunk x env = setLocalEnv env (eval x >>= quote)++quoteNePrim :: PrimInfo -> Args Value -> Eval (Neutral Normal)+quoteNePrim pr = fmap (NePrim pr) . quoteArgs++quoteNeApp :: Neutral Value -> Value -> Eval (Neutral Normal)+quoteNeApp x y = NeApp <$> quoteNeutral x <*> quote y++quoteNeTyApp :: Neutral Value -> Type -> Eval (Neutral Normal)+quoteNeTyApp x ty = NeTyApp <$> quoteNeutral x <*> pure ty++quoteNeLetrec :: [(Id, Value)] -> Value -> Eval (Neutral Normal)+quoteNeLetrec bs x =+ withIds bs (NeLetrec <$> quoteBinders bs <*> quote x)++quoteNeCase :: Value -> Type -> [(Pat, Value)] -> Eval (Neutral Normal)+quoteNeCase x ty alts =+ NeCase <$> quote x <*> pure ty <*> quoteAlts alts
src-ghc/Clash/GHC/Util.hs view
@@ -1,11 +1,20 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module Clash.GHC.Util where +#if MIN_VERSION_ghc(9,0,0)+import GHC.Utils.Outputable (SDoc)+import GHC.Utils.Error (mkPlainErrMsg)+import GHC.Plugins+ (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO,+ noSrcSpan, text, throwOneError)+#else import Outputable (SDoc) import ErrUtils (mkPlainErrMsg)-import GHC (GhcMonad(..), printException) import GhcPlugins (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO, noSrcSpan, text, throwOneError)+#endif+import GHC (GhcMonad(..), printException) import Control.Exception (Exception(..), ErrorCall(..)) import GHC.Exception (SomeException)