clash-ghc 1.4.7 → 1.6.0
raw patch · 29 files changed
+1076/−7072 lines, 29 filesdep +data-binary-ieee754dep −bifunctorsdep ~clash-libdep ~clash-preludedep ~ghcPVP ok
version bump matches the API change (PVP)
Dependencies added: data-binary-ieee754
Dependencies removed: bifunctors
Dependency ranges changed: clash-lib, clash-prelude, ghc, ghc-boot, ghci
API changes (from Hackage documentation)
- Clash.GHC.Evaluator: stepLetRec :: [LetBinding] -> Term -> Step
+ Clash.GHC.Evaluator: stepLet :: Bind Term -> Term -> Step
- 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.GenerateBindings: generateBindings :: ClashOpts -> Ghc () -> [FilePath] -> [FilePath] -> [FilePath] -> HDL -> String -> Maybe DynFlags -> IO (ClashEnv, ClashDesign)
- Clash.GHC.NetlistTypes: ghcTypeToHWType :: Int -> Bool -> CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))
+ Clash.GHC.NetlistTypes: ghcTypeToHWType :: Int -> CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))
- Clash.GHCi.Common: getMainTopEntity :: HasCallStack => String -> BindingMap -> [TopEntityT] -> String -> IO (TopEntityT, [TopEntityT])
+ Clash.GHCi.Common: getMainTopEntity :: HasCallStack => String -> ClashDesign -> String -> IO (TopEntityT, [TopEntityT])
Files
- CHANGELOG.md +73/−0
- clash-ghc.cabal +12/−24
- src-bin-8.10/Clash/GHCi/UI.hs +33/−56
- src-bin-8.10/Clash/Main.hs +20/−13
- src-bin-841/Clash/GHCi/HsVersions.h +0/−65
- src-bin-841/Clash/GHCi/UI.hs +0/−3982
- src-bin-841/Clash/GHCi/UI/Info.hs +0/−366
- src-bin-841/Clash/GHCi/UI/Monad.hs +0/−475
- src-bin-841/Clash/GHCi/UI/Tags.hs +0/−216
- src-bin-841/Clash/Main.hs +0/−1042
- src-bin-861/Clash/GHCi/UI.hs +33/−56
- src-bin-861/Clash/GHCi/UI/Monad.hs +0/−1
- src-bin-861/Clash/Main.hs +21/−12
- src-bin-881/Clash/GHCi/UI.hs +33/−56
- src-bin-881/Clash/Main.hs +20/−13
- src-bin-9.0/Clash/GHCi/UI.hs +34/−57
- src-bin-9.0/Clash/GHCi/UI/Info.hs +0/−1
- src-bin-9.0/Clash/Main.hs +20/−13
- src-bin-common/Clash/GHCi/Common.hs +9/−10
- src-ghc/Clash/GHC/ClashFlags.hs +101/−44
- src-ghc/Clash/GHC/Evaluator.hs +23/−20
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +161/−108
- src-ghc/Clash/GHC/GHC2Core.hs +81/−72
- src-ghc/Clash/GHC/GenerateBindings.hs +38/−35
- src-ghc/Clash/GHC/LoadInterfaceFiles.hs +284/−201
- src-ghc/Clash/GHC/LoadModules.hs +20/−80
- src-ghc/Clash/GHC/NetlistTypes.hs +15/−9
- src-ghc/Clash/GHC/PartialEval/Eval.hs +33/−37
- src-ghc/Clash/GHC/PartialEval/Quote.hs +12/−8
CHANGELOG.md view
@@ -1,4 +1,77 @@ # Changelog for the Clash project+## 1.6.0 *Feb 10th 2022*+Added:+ * `Clash.Class.Counter`: a class that defines a odometer-style supercounter. [#1763](https://github.com/clash-lang/clash-compiler/pull/1763)+ * `isLike` function for BitPack types. [#1774](https://github.com/clash-lang/clash-compiler/pull/1774)+ * 'seqErrorX' for catching both `XException` and `ErrorCall`. [#1774](https://github.com/clash-lang/clash-compiler/pull/1774)+ * `Clash.Explicit.BlockRam.File.memFile`, a function for creating the contents of the data files this blockRAM uses. Can also be imported from `Clash.Prelude.BlockRam.File`, `Clash.Prelude.ROM.File` and `Clash.Explicit.ROM.File`. [#1840](https://github.com/clash-lang/clash-compiler/pull/1840)+ * Support for Yosys compatible SVA to `Clash.Verification`. This enables formal verification using SymbiYosis for Verilog and SystemVerilog. [#1798](https://github.com/clash-lang/clash-compiler/pull/1798)+ * `Clash.Explicit.Signal.Delayed.forward`, a function that can be used to retime a `DSignal` into the future without applying any logic. [#1882](https://github.com/clash-lang/clash-compiler/pull/1882)+ * `Clash.Signal.andEnable` is the `HiddenEnable` version of `Clash.Explicit.Signal.andEnable` (formerly known as `enable`) [#1849](https://github.com/clash-lang/clash-compiler/pull/1849)+ * `runUntil`, a function to sample a signal until it returns a value that satisfies the user-given test. It is a convenience function that, among others, allow easy running of a `testBench` style function in Haskell simulation, logging assertion failures to stderr. [#1940](https://github.com/clash-lang/clash-compiler/pull/1940)+ * Support for true dual ported block ram through `Clash.Prelude.BlockRam.trueDualPortBlockRam` and `Clash.Explicit.BlockRam.trueDualPortBlockRam`. [#1726](https://github.com/clash-lang/clash-compiler/pull/1726) [#1975](https://github.com/clash-lang/clash-compiler/pull/1975)+ * `clash-{prelude,lib}-hedgehog` packages which provide generators for types in `clash-prelude` and `clash-lib`. The former is published on Hackage. [#1976](https://github.com/clash-lang/clash-compiler/pull/1976)+ * Clash now contains black boxes which are verilator compatible. When running with `--verilog` or `--systemverilog` a C++ shim is automatically produced which can be used to quickly generate a verilated executable. Users who wish to interact with verilator simulations are recommended to use [clashilator](https://github.com/gergoerdi/clashilator). [#2019](https://github.com/clash-lang/clash-compiler/pull/2019)+ * Support for YAML blackboxes. Clash will now pickup on files with a `.primitives.yaml` extension. While we recommend upgrading your primitive files to the new format, old style primitives are still supported. We've included a tool to automatically upgrade your JSON files, see [#2037](https://github.com/clash-lang/clash-compiler/pull/2037)+ * `MemBlob`: a datastructure for efficient constants, typically used for initializing memories. [#2041](https://github.com/clash-lang/clash-compiler/pull/2041)++Fixed:++ * BlockRam simulation is now less strict. [#1458](https://github.com/clash-lang/clash-compiler/issues/1458)+ * Don't overflow VHDL's integer type when addressing RAM/ROM in simulation.Addresses are masked to 32 bits to be sure to keep it within the simulator's range. [#1875](https://github.com/clash-lang/clash-compiler/pull/1875)+ * `show` on `BitVector 0` no longer results in an empty string. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785)+ * Clash now preserves transfinite floating numbers (NaN, Infinity) when packing/unpacking [#1803](https://github.com/clash-lang/clash-compiler/issues/1803)+ * `SynthesisAnnotation`s can now be defined in type synoynms without being excluded from the generated HDL [#1771](https://github.com/clash-lang/clash-compiler/issues/1771)+ * Manifest files now correctly list bidirectional ports as "inout" rather than "in" [#1843](https://github.com/clash-lang/clash-compiler/issues/1843)+ * `div`/`rem`/`mod` now avoid division by zero during VHDL simulation. Due to the use of concurrent statements, even unreachable code would previously result in simulation error [#1873](https://github.com/clash-lang/clash-compiler/pull/1873)+ * Don't overflow the range of VHDL's natural type in shift/rotate, leading to simulation issues. Shift now saturates to a 31-bit shift amount. For rotate, in simulation only, the rotate amount is modulo the word width of the rotated value [#1874](https://github.com/clash-lang/clash-compiler/pull/1874)+ * `shiftL` for Clash datatypes does not cause a crash anymore when running Clash code with a really large shift amount [#1874](https://github.com/clash-lang/clash-compiler/pull/1874)+ * VHDL generated for `Signed.fromInteger` now truncates, like the Clash simulation, when the result is smaller than the argument [#1874](https://github.com/clash-lang/clash-compiler/pull/1874)+ * Clash now preserves boolean combinatorial logic better when generating HDL [#1881](https://github.com/clash-lang/clash-compiler/issues/1881)+ * `valid` field of `TemplateFunction` is now checked for includes [#1945](https://github.com/clash-lang/clash-compiler/issues/1945)+ * Clash now generates clock generators that ensure that the amount of time between simulation start and the first active edge of the clock is equal to (/or longer than/) the period of the clock. The first active edges of the clocks do still occur simultaneously. [#2001](https://github.com/clash-lang/clash-compiler/issues/2001)+ * Expected values in assert become undefined when using `-fclash-compile-ultra` [#2040](https://github.com/clash-lang/clash-compiler/issues/2040)+ * `toEnum`/`fromEnum` on sized types is now less eager to report warnings about integer functions being used [#2046](https://github.com/clash-lang/clash-compiler/issues/2046)++Changed:++ * `Clash.Verification.PrettyPrinters` has been moved from clash-prelude to to `Clash.Verification.Pretty` in `clash-lib`. [#1798](https://github.com/clash-lang/clash-compiler/pull/1798)+ * RAM/ROM functions: They now throw `XExeception` for out-of-bounds address inputs, so this condition no longer aborts simulation. [#1875](https://github.com/clash-lang/clash-compiler/pull/1875)+ * `Vec`'s show instance now generates valid Haskell. [#1776](https://github.com/clash-lang/clash-compiler/issues/1776)+ * `ShowX` and its functions now produce valid Haskell [#1782](https://github.com/clash-lang/clash-compiler/issues/1782)+ * `bLit` now infers the size of the generated BitVector from the string given to it. This means you don't have to give it an explicit type signature anymore. This does slightly modify the syntax needed to invoke `bLit`. E.g., `$$(bLit "00..1") :: BitVector 5` should be rewritten as `$(bLit "00..1")`. If you relied on the size inference, wrap the new invocation in `resize`. For example: `resize $(bLit "00..1")`. [#1784](https://github.com/clash-lang/clash-compiler/pull/1784)+ * `NumericUnderscores` is now enabled by default in `clash`, `clashi`, and starter projects using Clash >=1.6. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785)+ * `Show` instance of `BitVector` now includes a `0b` prefix, making it a copyable expression for fully defined vectors. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785)+ * `blockRam` uses `STArray` as the underlying representation to improve simulation performance [#1878](https://github.com/clash-lang/clash-compiler/pull/1878)+ * `asyncRom` now throws `XException` for out-of-bounds addressing, no longer aborting simulation [#1878](https://github.com/clash-lang/clash-compiler/pull/1878)+ * Clash now renders ADTs with all zero-width fields as enumerations in VHDL [#1879](https://github.com/clash-lang/clash-compiler/pull/1879)+ * A warning about possible hard-to-debug issues has been added to the `Clash.Signal` documentation on hidden clocks, resets, and enables, in the form of the section named "Monomorphism restriction leads to surprising behavior" [#1960](https://github.com/clash-lang/clash-compiler/pull/1960)+ * `Clash.Explicit.Testbench.outputVerifier` and `outputVerifierBitVector` now emit a warning if they are used improperly. This situation only arises when they are used in synthesized code rather than a test bench context. When the clock domains `circuitDom` and `testDom` are two different domains, the clock crossing inside `outputVerifier` is only suitable inside a test bench, not inside a synthesized circuit. Clash now emits a warning for this case. [#1931](https://github.com/clash-lang/clash-compiler/pull/1931)+ * `resetSynchronizer` now no longer takes an `Enable` argument. The argument was already marked for removal and was ignored. [#1964](https://github.com/clash-lang/clash-compiler/pull/1964)+ * Clash can now compile multiple entities concurrently, providing speedups to designs with multiple entities to build [#2034](https://github.com/clash-lang/clash-compiler/pull/2034)+ * All `asyncRam` variants and `asyncFIFOSynchronizer` now require that the data has an `NFDataX` instance. [#2055](https://github.com/clash-lang/clash-compiler/pull/2055)+ * Clash now respects the `-Werror` option from GHC [#2066](https://github.com/clash-lang/clash-compiler/pull/2066)+ * `asyncFIFOSynchronizer` now uses the synchronous dual-ported RAM `trueDualPortBlockRam`, where it previously used a dual-ported RAM with an asynchronous read port `asyncRam`. With this change it's nearly guaranteed that `asyncFIFOSynchronizer` actually synthesizes to a circuit that uses the dual-ported RAMs found on most FPGAs. [#2083](https://github.com/clash-lang/clash-compiler/pull/2083)++Deprecated:+ * The function `Clash.Explicit.Signal.enable` is renamed to `andEnable` and the existing name deprecated [#1849](https://github.com/clash-lang/clash-compiler/pull/1849)+ * '-fclash-float-support': it is now on by default and can't be turned off. [#2048](https://github.com/clash-lang/clash-compiler/pull/2048)++Removed:++ * GHC 8.4 is no longer supported. Users should upgrade to at least GHC 8.6. [#1762](https://github.com/clash-lang/clash-compiler/pull/1762)++Internal changes:+ * `clash-lib` now uses `Data.Monoid.Ap` instead of `Data.Semigroup.Monad.Mon`. This means users defining primitives with `TemplateFunction` will need to replace `Mon`/`getMon` with `Ap`/`getAp`. [#1835](https://github.com/clash-lang/clash-compiler/pull/1835)+ * Clash now supports more expressive debug options at the command line [#1800](https://github.com/clash-lang/clash-compiler/issues/1800).+ * Added `zeroWidthSpec` transformation [#1891](https://github.com/clash-lang/clash-compiler/pull/1891)+ * Added `collapseRHSNoops` inlining stage and `WorkIdentity` constructor [#1896](https://github.com/clash-lang/clash-compiler/pull/1896)+ * Added `HasType` and `InferType` classes for getting / inferring core types from data representing some typed "thing" [#1915](https://github.com/clash-lang/clash-compiler/pull/1915)+ * Added `HasFreeVars` class for getting free variables from data "containing" variables [#1917](https://github.com/clash-lang/clash-compiler/pull/1917)+ * Added the primitive equality type (`~#`) to `Clash.Core.TysPrim`. In order to make this change, `undefinedTy` and `unsafeCoerceTy` were moved from `Clash.Core.Type` to `Clash.Core.Util`. [#1955](https://github.com/clash-lang/clash-compiler/pull/1955)+ * Clash now keeps information about which let bindings are recursive from GHC core. This can be used to avoid performing free variable calculations, or sorting bindings in normalization. [#1980](https://github.com/clash-lang/clash-compiler/pull/1980) [#2000](https://github.com/clash-lang/clash-compiler/pull/2000)+ * Manifest files now use SHA256 for a cache invalidation digest [#1985](https://github.com/clash-lang/clash-compiler/pull/1985)+ ## 1.4.7 *Jan 30th 2022* Fixed: * Clash now shows days in time strings for compile runs which take longer than a day [#1989](https://github.com/clash-lang/clash-compiler/compare/issue-1989).
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.4.7+Version: 1.6.0 Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its@@ -46,8 +46,7 @@ Extra-source-files: README.md, CHANGELOG.md, LICENSE_GHC,- cbits/PosixSource.h,- src-bin-841/Clash/GHCi/HsVersions.h+ cbits/PosixSource.h source-repository head type: git@@ -66,16 +65,10 @@ 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- GHC-Options: -Wall -Wcompat+ GHC-Options: -Wall -Wcompat -threaded -rtsopts if flag(dynamic) GHC-Options: -dynamic extra-libraries: pthread@@ -105,6 +98,7 @@ DerivingStrategies InstanceSigs KindSignatures+ NoStarIsType ScopedTypeVariables StandaloneDeriving TupleSections@@ -115,9 +109,6 @@ 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@@ -129,8 +120,6 @@ HS-Source-Dirs: src-bin-881 elif impl(ghc >= 8.6.0) HS-Source-Dirs: src-bin-861- elif impl(ghc >= 8.4.1)- HS-Source-Dirs: src-bin-841 GHC-Options: -Wall -Wcompat if impl(ghc >= 8.10.0)@@ -145,14 +134,14 @@ Build-Depends: array >= 0.4 && < 0.6, base >= 4.11 && < 5,- bifunctors >= 4.1.1 && < 6.0, bytestring >= 0.9 && < 0.12, Cabal, containers >= 0.5.4.0 && < 0.7,+ data-binary-ieee754 >= 0.4.4 && < 0.6, directory >= 1.2 && < 1.4, extra >= 1.6 && < 1.8, filepath >= 1.3 && < 1.5,- ghc >= 8.4.0 && < 9.1,+ ghc >= 8.6.0 && < 9.1, process >= 1.2 && < 1.7, hashable >= 1.1.2.3 && < 1.5, haskeline >= 0.7.0.3 && < 0.9,@@ -163,17 +152,17 @@ transformers >= 0.5.2.0 && < 0.7, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.4.7,- clash-prelude == 1.4.7,+ clash-lib == 1.6.0,+ clash-prelude == 1.6.0, concurrent-supply >= 0.1.7 && < 0.2, 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.14,- ghc-boot >= 8.4.0 && < 9.1,+ ghc-boot >= 8.6.0 && < 9.1, ghc-prim >= 0.3.1.0 && < 0.8,- ghci >= 8.4.0 && < 9.1,+ ghci >= 8.6.0 && < 9.1, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0, primitive >= 0.5.0.1 && < 1.0,@@ -218,7 +207,8 @@ Clash.GHCi.Common - Other-Modules: Clash.GHCi.UI+ Other-Modules: Clash.GHCi.Leak+ Clash.GHCi.UI Clash.GHCi.UI.Info Clash.GHCi.UI.Monad Clash.GHCi.UI.Tags@@ -228,7 +218,5 @@ Clash.GHC.LoadInterfaceFiles Clash.GHC.Util Paths_clash_ghc- if impl(ghc >= 8.6.0)- Other-Modules: Clash.GHCi.Leak if impl(ghc >= 8.8.0) Other-Modules: Clash.GHCi.Util
src-bin-8.10/Clash/GHCi/UI.hs view
@@ -98,11 +98,11 @@ 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, isSuffixOf, nub, partition, sort, sortBy, (\\) )+import Data.Proxy import qualified Data.Set as S import Data.Maybe import Data.Map (Map)@@ -145,31 +145,22 @@ import Clash.GHCi.Leak -- clash additions-import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend(initBackend, hdlKind, primDirs)) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver-import Clash.Driver.Types (ClashOpts(..))+import Clash.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..)) -#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 {@@ -2146,11 +2137,13 @@ 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'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi () makeHDL' backend opts lst = go =<< case lst of srcs@(_:_) -> return srcs [] -> do@@ -2186,27 +2179,21 @@ _ <- GHC.setSessionDynFlags dflags reloadModule "" -makeHDL :: GHC.GhcMonad m- => Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)- -> GHC.Ghc ()- -> IORef ClashOpts- -> [FilePath]- -> m ()-makeHDL backend startAction optsRef srcs = do+makeHDL+ :: forall backend m+ . (GHC.GhcMonad m, Backend backend)+ => Proxy backend+ -> GHC.Ghc ()+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL Proxy 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'+ hdl = hdlKind backend -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags hidir <- hiDir dflags@@ -2218,53 +2205,43 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc lw frcUdf (coerce xOptBB)+ backend = initBackend @backend opts2 checkMonoLocalBinds dflags checkImportDirs opts0 idirs - primDirs <- Clash.Backend.primDirs backend'+ primDirs_ <- primDirs backend forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]- (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-- generateBindings startAction color primDirs idirs dbs hdl src (Just dflags)+ (clashEnv, clashDesign) <- generateBindings opts2 startAction primDirs_ idirs dbs hdl src (Just dflags) - let getMain = getMainTopEntity src bindingsMap topEntities+ let getMain = getMainTopEntity src clashDesign mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)- prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ prepTime <- startTime `deepseq` designBindings clashDesign `deepseq` envTyConMap clashEnv `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+ clashEnv+ clashDesign+ (Just backend)+ (ghcTypeToHWType iw) ghcEvaluator-#else evaluator-#endif- topEntities mainTopEntity- opts2- (startTime,prepTime)+ startTime makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
src-bin-8.10/Clash/Main.hs view
@@ -52,6 +52,7 @@ import DriverPhases import BasicTypes ( failed ) import DynFlags hiding (WarnReason(..))+import EnumSet as EnumSet import ErrUtils import FastString import Outputable@@ -81,25 +82,23 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.Char import Data.List ( isPrefixOf, partition, intercalate, nub )+import Data.Proxy import Data.Maybe -- clash additions import Paths_clash_ghc import Clash.GHCi.UI (makeHDL) import Exception (gcatch)-import Data.IORef (IORef, newIORef, readIORef)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef') import qualified Data.Version (showVersion) -import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend) 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)@@ -238,6 +237,10 @@ (dflags3, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags2 args + -- Propagate -Werror to Clash+ liftIO . modifyIORef' clashOpts $ \opts ->+ opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }+ let dflags4 = case lang of HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> let platform = targetPlatform dflags3@@ -1004,20 +1007,24 @@ -- 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+ :: forall backend+ . Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap fst srcs makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
− src-bin-841/Clash/GHCi/HsVersions.h
@@ -1,65 +0,0 @@-#pragma once--#if 0--IMPORTANT! If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--/* Useful in the headers that we share with the RTS */-#define COMPILING_GHC 1--/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */-/* #include "ghc_boot_platform.h" */--/* Pull in the autoconf defines (HAVE_FOO), but don't include- * ghcconfig.h, because that will include ghcplatform.h which has the- * wrong platform settings for the compiler (it has the platform- * settings for the target plat instead). */-/* #include "ghcautoconf.h" */--#define GLOBAL_VAR(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobal (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobalM (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples: Assuming flagSet :: String -> m Bool------ do { c <- getChar; MASSERT( isUpper c ); ... }--- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }--- do { str <- getStr; ASSERTM( flagSet str ); .. }--- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. }--- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e) ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e) do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () }
− src-bin-841/Clash/GHCi/UI.hs
@@ -1,3982 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--{-# OPTIONS -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- 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, runDecls )-import Clash.GHCi.UI.Tags-import Clash.GHCi.UI.Info-import Debugger---- The GHC interface-import GHCi-import GHCi.RemoteTypes-import GHCi.BreakArray-import DynFlags-import ErrUtils hiding (traceCmd)-import Finder-import GhcMonad ( modifySession )-import qualified GHC-import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),- TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,- getModuleGraph, handleSourceError )-import HsImpExp-import HsSyn-import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,- setInteractivePrintName, hsc_dflags, msObjFilePath )-import Module-import Name-import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,- listVisibleModuleNames, pprFlag )-import IfaceSyn ( showToHeader )-import PprTyThing-import PrelNames-import RdrName ( getGRE_NameQualifier_maybes, getRdrName )-import SrcLoc-import qualified Lexer--import StringBuffer-import Outputable hiding ( printForUser, printForUserPartWay )---- Other random utilities-import BasicTypes hiding ( isTopLevel )-import Digraph-import Encoding-import FastString-import Linker-import Maybes ( orElse, expectJust )-import NameSet-import Panic hiding ( showException )-import Util-import qualified GHC.LanguageExtensions as LangExt---- 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.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.Coerce-import Data.Function-import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )-import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,- partition, sort, sortBy )-import qualified Data.Set as S-import Data.Maybe-import qualified Data.Map as M-import Data.Time.LocalTime ( getZonedTime )-import Data.Time.Format ( formatTime, defaultTimeLocale )-import Data.Version ( showVersion )-import Prelude hiding ((<>))--import Exception hiding (catch)-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 )---- 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, completeIdentifier),- ("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),- ("edit", keepGoing' editFile, completeFilename),- ("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)- ] ++ 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" ++- " :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" ++- " :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" ++- " :!<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 breakpoint\n" ++- " :delete * delete 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 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>" ++- "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"--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 "%s> "-default_prompt_cont = generatePromptFunctionFromString "%s| "--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.- dflags <- getDynFlags- let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)- . (`xopt_unset` LangExt.MonomorphismRestriction)- $ dflags- GHC.setInteractiveDynFlags dflags'-- lastErrLocationsRef <- liftIO $ newIORef []- progDynFlags <- GHC.getProgramDynFlags- _ <- GHC.setProgramDynFlags $- progDynFlags { log_action = ghciLogAction 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 = default_prompt,- prompt_cont = default_prompt_cont,- stop = default_stop,- editor = default_editor,- options = [],- -- 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 = [],- tickarrays = emptyModuleEnv,- ghci_commands = availableCommands config,- ghci_macros = [],- last_command = Nothing,- 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 ()--resetLastErrorLocations :: GHCi ()-resetLastErrorLocations = do- st <- getGHCiState- liftIO $ writeIORef (lastErrorLocations st) []--ghciLogAction :: IORef [(FastString, Int)] -> LogAction-ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do- defaultLogAction dflags flag severity srcSpan style 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-- current_dir = return (Just ".clashi")-- 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-- dot_cfgs <- if ignore_dot_ghci then return [] else do- dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]- liftIO $ filterM checkFileAndDirPerms dot_files- mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs-- 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 $ (catMaybes mdot_cfgs) ++ arg_cfgs- -- nub, because we don't want to read .ghci twice if the CWD is $HOME.-- -- 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- runGHCiExpressions exprs-- -- and finally, exit- liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."--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 Trac #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 </> ".clashi_history"))- (True, _) -> liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "clashi_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 :: InputT GHCi ()-incrementLineNo = modifyGHCiState incLineNo- where- incLineNo st = st { line_number = line_number st + 1 }--fileLoop :: Handle -> InputT GHCi (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 :: GHCi (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 = \_ _ -> do- (context, modules_names, line) <- getInfoForPrompt-- let- processString :: String -> GHCi SDoc- processString ('%':'s':xs) =- liftM2 (<>) (return modules_list) (processString xs)- where- modules_list = context <> modules_bit- modules_bit = 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-- processString promptS--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 :: GHCi (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 :: Maybe String -> Bool -> GHCi ()-installInteractivePrint Nothing _ = return ()-installInteractivePrint (Just ipFun) exprmode = do- ok <- trySuccess $ do- name <- head <$> GHC.parseName ipFun- 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 (Maybe Bool)- -- We want to return () here, but have to return (Maybe Bool)- -- because gmask is not polymorphic enough: we want to use- -- unmask at two different types.-runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do- b <- ghandle (\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 Nothing- 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 -> ghciHandle (\e -> lift $ eh e >>= return . Just) $- handleSourceError printErrorAndFail- (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 "" `GHC.gfinally`- 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 (Maybe Bool)-- -- command- doCommand stmt | (':' : cmd) <- removeSpaces stmt = do- result <- specialCommand cmd- case result of- True -> return Nothing- _ -> return $ Just True-- -- 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 $ Just True- Just ml_stmt -> do- -- temporarily compensate line-number for multi-line input- result <- timeIt runAllocs $ lift $- runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion- return $ Just (runSuccess result)- 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- result <- timeIt runAllocs $ lift $- runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion- return $ Just (runSuccess result)-- -- 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 :: String -> InputT GHCi (Maybe String)- -> InputT GHCi (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 :: [String] -> GHCi ()-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 :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt stmt step = do- dflags <- GHC.getInteractiveDynFlags- if | GHC.isStmt dflags stmt -> run_stmt- | GHC.isImport dflags stmt -> 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 dflags stmt -> throwGhcException- (CmdLineError "error: expecting a single import declaration")- -- Note: `GHC.isDecl` returns False on input like- -- `data Infix a b = a :@: b; infixl 4 :@:`- -- and should therefore not be used here.- | otherwise -> run_decl-- where- run_import = do- addImportToContext stmt- return (Just (GHC.ExecComplete (Right []) 0))-- run_decl =- do _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runDecls stmt- case m_result of- Nothing -> return Nothing- Just result ->- Just <$> afterRunStmt (const True)- (GHC.ExecComplete (Right result) 0)-- run_stmt =- 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.runStmt stmt step- case m_result of- Nothing -> return Nothing- Just result -> Just <$> afterRunStmt (const True) result---- | Clean up the GHCi environment after a statement has run-afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi 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 ::- Maybe GHC.BreakInfo -> GHCi (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) <- breaks st,- breakModule loc == md,- breakTick loc == nm ]--printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()-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 :: [Name] -> GHCi ()-printTypeOfNames names- = mapM_ (printTypeOfName ) $ sortBy compareNames names--compareNames :: Name -> Name -> Ordering-n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2- where compareWith n = (getOccString n, getSrcSpan n)--printTypeOfName :: Name -> GHCi ()-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 <- lift $ 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 :: String -> GHCi Bool-shellEscape str = liftIO (system str >> return False)--lookupCommand :: String -> GHCi (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' :: String -> GHCi (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 `isPrefixOf`) . 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--getCurrentBreakSpan :: GHCi (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 :: GHCi (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 :: GHCi (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 :: GHCi () -> String -> GHCi ()-noArgs m "" = m-noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"--withSandboxOnly :: String -> GHCi () -> GHCi ()-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 :: String -> GHCi ()-help _ = do- txt <- long_help `fmap` getGHCiState- liftIO $ putStr txt---------------------------------------------------------------------------------- :info--info :: Bool -> String -> InputT GHCi ()-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 :: String -> GHCi ()-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 :: String -> GHCi ()-runRun s = case toCmdArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right (cmd, args) -> doWithArgs args cmd--doWithArgs :: [String] -> String -> GHCi ()-doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++- show args ++ " (" ++ cmd ++ ")"]---------------------------------------------------------------------------------- :cd--changeDirectory :: String -> InputT GHCi ()-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."- GHC.setTargets []- _ <- GHC.load LoadAllTargets- lift $ setContextAfterLoad False []- GHC.workingDirectoryChanged- dir' <- expandPath dir- liftIO $ setCurrentDirectory dir'- dflags <- getDynFlags- -- With -fexternal-interpreter, we have to change the directory of the subprocess too.- -- (this gives consistent behavior with and without -fexternal-interpreter)- when (gopt Opt_ExternalInterpreter dflags) $- lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']--trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag-trySuccess act =- handleSourceError (\e -> do GHC.printException e- return Failed) $ do- act---------------------------------------------------------------------------------- :edit--editFile :: String -> InputT GHCi ()-editFile str =- do file <- if null str then lift 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 occured during the--- last load/reaload, then we could start the editor focused on the first--- of those.-chooseEditFile :: GHCi 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 :: Bool{-overwrite-} -> String -> GHCi ()-defineMacro _ (':':_) =- liftIO $ putStrLn "macro name cannot start with a colon"-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- if (not overwrite && macro_name `elem` defined)- then throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is already defined"))- else do-- -- compile the expression- handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr definition- -- > ghciStepIO . definition :: String -> IO String- let stringTy = nlHsTyVar stringTy_RDR- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)- `mkHsApp` (nlHsPar expr)- tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)- new_expr = L (getLoc expr) $ ExprWithTySig 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 :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool-runMacro fun s = do- hsc_env <- GHC.getSession- str <- liftIO $ evalStringToIOString hsc_env fun s- enqueueCommands (lines str)- return False----------------------------------------------------------------------------------- :undef--undefineMacro :: String -> GHCi ()-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 :: String -> GHCi ()-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 :: GHCi (LHsExpr GhcPs)-getGhciStepIO = do- ghciTyConName <- GHC.getGHCiMonad- let stringTy = nlHsTyVar stringTy_RDR- ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar (getRdrName ghciStepIoMName)- tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)- return $ noLoc $ ExprWithTySig body tySig---------------------------------------------------------------------------------- :check--checkModule :: String -> InputT GHCi ()-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----------------------------------------------------------------------------------- :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 :: InputT GHCi a -> InputT GHCi a-wrapDeferTypeErrors load =- gbracket- (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 :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag-loadModule fs = timeIt (const Nothing) (loadModule' fs)---- | @:load@ command-loadModule_ :: [FilePath] -> InputT GHCi ()-loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))--loadModuleDefer :: [FilePath] -> InputT GHCi ()-loadModuleDefer = wrapDeferTypeErrors . loadModule_--loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi 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.-- -- unload first- _ <- GHC.abandonAll- lift discardActiveBreakPoints- GHC.setTargets []- _ <- GHC.load LoadAllTargets-- GHC.setTargets targets- doLoadAndCollectInfo False LoadAllTargets---- | @:add@ command-addModule :: [FilePath] -> InputT GHCi ()-addModule files = do- lift 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 :: Target -> InputT GHCi Bool- checkTarget (Target (TargetModule m) _ _) = checkTargetModule m- checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f-- checkTargetModule :: ModuleName -> InputT GHCi 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 :: [FilePath] -> InputT GHCi ()-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 :: String -> InputT GHCi ()-reloadModule m = void $ doLoadAndCollectInfo True loadTargets- where- loadTargets | null m = LoadAllTargets- | otherwise = LoadUpTo (GHC.mkModuleName m)--reloadModuleDefer :: String -> InputT GHCi ()-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 :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag-doLoadAndCollectInfo retain_context howmuch = do- doCollectInfo <- lift (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--doLoad :: Bool -> LoadHowMuch -> InputT GHCi 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.- lift discardActiveBreakPoints-- lift 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.- gbracket (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 :: SuccessFlag- -> Bool -- keep the remembered_ctx, as far as possible (:reload)- -> InputT GHCi ()-afterLoad ok retain_context = do- lift revertCAFs -- always revert CAFs on load.- lift discardTickArrays- loaded_mods <- getLoadedModules- modulesLoadedMsg ok loaded_mods- lift $ setContextAfterLoad retain_context loaded_mods--setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()-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- :: Bool -- True <=> keep all of remembered_ctx- -- False <=> just keep package imports- -> [InteractiveImport] -- new context- -> GHCi ()--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 :: [InteractiveImport] -> GHCi [InteractiveImport]-keepPackageImports = filterM is_pkg_import- where- is_pkg_import :: InteractiveImport -> GHCi Bool- is_pkg_import (IIModule _) = return False- is_pkg_import (IIDecl d)- = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)- case e :: Either SomeException Module of- Left _ -> return False- Right m -> return (not (isHomeModule m))- where- mod_name = unLoc (ideclName d)---modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()-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 `gfinally` 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.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 }- 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 (coerce xOptBB)-- checkMonoLocalBinds dflags- checkImportDirs opts0 idirs-- primDirs <- Clash.Backend.primDirs backend'-- forM_ srcs $ \src -> do- -- Generate bindings:- let dbs = reverse [p | PackageDB (PkgConfFile 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 :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState)--makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-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 -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState)---------------------------------------------------------------------------------- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.--typeOfExpr :: String -> InputT GHCi ()-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 :: String -> InputT GHCi ()-typeAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- (info, ty) <- findType infos span' sample- lift $ printForUserModInfo (modinfoInfo info)- (sep [text sample,nest 2 (dcolon <+> ppr ty)])---------------------------------------------------------------------------------- | @:uses@ command--usesCmd :: String -> InputT GHCi ()-usesCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- uses <- findNameUses infos span' sample- forM_ uses (liftIO . putStrLn . showSrcSpan)---------------------------------------------------------------------------------- | @:loc-at@ command--locAtCmd :: String -> InputT GHCi ()-locAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- (_,_,sp) <- findLoc infos span' sample- liftIO . putStrLn . showSrcSpan $ sp---------------------------------------------------------------------------------- | @:all-types@ command--allTypesCmd :: String -> InputT GHCi ()-allTypesCmd _ = runExceptGhcMonad $ do- infos <- 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)- (mkRealSrcLoc fs el ec)-- 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 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- ec = srcSpanEndCol spn---------------------------------------------------------------------------------- | @:kind@ command--kindOfType :: Bool -> String -> InputT GHCi ()-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 :: String -> InputT GHCi 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>")--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 :: String -> InputT GHCi ()-isSafeCmd m =- case words m of- [s] | looksLikeModuleName s -> do- md <- lift $ lookupModule s- isSafeModule md- [] -> do md <- guessCurrentModule "issafe"- isSafeModule md- _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")--isSafeModule :: Module -> InputT GHCi ()-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- | thisPackage dflags == moduleUnitId md = True- | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)-- tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)- | otherwise = S.partition part deps- where part pkg = trusted $ getInstalledPackageDetails dflags pkg---------------------------------------------------------------------------------- :browse---- Browsing a module's contents--browseCmd :: Bool -> String -> InputT GHCi ()-browseCmd bang m =- case words m of- ['*':s] | looksLikeModuleName s -> do- md <- lift $ wantInterpretedModule s- browseModule bang md False- [s] | looksLikeModuleName s -> do- md <- lift $ lookupModule s- browseModule bang md True- [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")- browseModule bang md True- _ -> throwGhcException (CmdLineError "syntax: :browse <module>")--guessCurrentModule :: String -> InputT GHCi 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 :: Bool -> Module -> Bool -> InputT GHCi ()-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 (compare `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 :: String -> GHCi ()-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 :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext starred unstarred = restoreContextOnFailure $ do- addModulesToContext_ starred unstarred--addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext_ starred unstarred = do- mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)- setGHCContextFromGHCiState--remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()-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 :: ModuleName -> GHCi ()- 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 :: [ModuleName] -> [ModuleName] -> GHCi ()-setContext starred unstarred = restoreContextOnFailure $ do- modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }- -- delete the transient context- addModulesToContext_ starred unstarred--addImportToContext :: String -> GHCi ()-addImportToContext str = restoreContextOnFailure $ do- idecl <- GHC.parseImportDecl str- addII (IIDecl idecl) -- #5836- setGHCContextFromGHCiState---- Util used by addImportToContext and addModulesToContext-addII :: InteractiveImport -> GHCi ()-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 :: GHCi a -> GHCi a-restoreContextOnFailure do_this = do- st <- getGHCiState- let rc = remembered_ctx st; tc = transient_ctx st- do_this `gonException` (modifyGHCiState $ \st' ->- st' { remembered_ctx = rc, transient_ctx = tc })---- -------------------------------------------------------------------------------- Validate a module that we want to add to the context--checkAdd :: InteractiveImport -> GHCi ()-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 :: GHCi ()-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 :: [InteractiveImport] -> GHCi [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 (ideclQualified d1) || 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 :: String -> GHCi ()-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- _ -> case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> setOptions wds--setiCmd :: String -> GHCi ()-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 :: Bool -> GHCi ()-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) (llvmTargets 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 :: [String] -> GHCi ()-setProg, setEditor, setStop :: String -> GHCi ()--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 })--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- if all ((/= nm) . fst) old_breaks- then printForUser (text "Breakpoint" <+> ppr nm <+>- text "does not exist")- else do- let new_breaks = map fn old_breaks- fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })- | otherwise = (i,loc)- setGHCiState st{ breaks = new_breaks }-setStop cmd = modifyGHCiState (\st -> st { stop = cmd })--setPrompt :: PromptFunction -> GHCi ()-setPrompt v = modifyGHCiState (\st -> st {prompt = v})--setPromptCont :: PromptFunction -> GHCi ()-setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})--setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()-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 :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()-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 :: (PromptFunction -> GHCi ()) -> String -> GHCi ()-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 :: Bool -> [String] -> GHCi ()-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"- GHC.setInteractiveDynFlags idflags1- installInteractivePrint (interactivePrint idflags1) False-- dflags0 <- getDynFlags- when (not interactive_only) $ do- (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts- new_pkgs <- 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..."- GHC.setTargets []- _ <- GHC.load LoadAllTargets- liftIO $ linkPackages hsc_env new_pkgs- -- 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{ pkgState = pkgState dflags2- , pkgDatabase = pkgDatabase 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 :: String -> GHCi ()-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 :: String -> GHCi ()--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 :: String -> GHCi ()-showCmd "" = showOptions False-showCmd "-a" = showOptions True-showCmd str = do- st <- getGHCiState- dflags <- getDynFlags-- let lookupCmd :: String -> Maybe (GHCi ())- lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds-- -- (show in help?, command name, action)- action :: String -> GHCi () -> (Bool, String, GHCi ())- action name m = (True, name, m)-- hidden :: String -> GHCi () -> (Bool, String, GHCi ())- 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" $ getDynFlags >>= liftIO . showLinkerState- , action "breaks" $ showBkptTable- , action "context" $ showContext- , action "packages" $ showPackages- , 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 :: String -> GHCi ()-showiCmd str = do- case words str of- ["languages"] -> showiLanguages -- backwards compat- ["language"] -> showiLanguages- ["lang"] -> showiLanguages -- useful abbreviation- _ -> throwGhcException (CmdLineError ("syntax: :showi language"))--showImports :: GHCi ()-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 :: GHCi ()-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 :: GHCi ()-showBindings = do- bindings <- GHC.getBindings- (insts, finsts) <- GHC.getInsts- docs <- mapM makeDoc (reverse bindings)- -- reverse so the new ones come last- let idocs = map GHC.pprInstanceHdr insts- fidocs = map GHC.pprFamInst finsts- 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 :: TyThing -> GHCi ()-printTyThing tyth = printForUser (pprTyThing showToHeader tyth)--showBkptTable :: GHCi ()-showBkptTable = do- st <- getGHCiState- printForUser $ prettyLocations (breaks st)--showContext :: GHCi ()-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--showPackages :: GHCi ()-showPackages = 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 :: GHCi ()-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 :: GHCi ()-showLanguages = getDynFlags >>= liftIO . showLanguages' False--showiLanguages :: GHCi ()-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) (llvmTargets dflags) `lang_set`- case language dflags of- Nothing -> Just Haskell2010- other -> other--showTargets :: GHCi ()-showTargets = mapM_ showTarget =<< GHC.getTargets- where- showTarget :: Target -> GHCi ()- 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- :: CompletionFunc GHCi---- | 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 `isPrefixOf`) 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))--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 :: String -> GHCi [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 :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi-wrapCompleter breakChars fun = completeWord Nothing breakChars- $ fmap (map simpleCompletion . nubSort) . fun--wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi-wrapIdentCompleter = wrapCompleter word_break_chars--wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi-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 dflags--completeExpression = completeQuotedWord (Just '\\') "\"" listFiles- completeIdentifier----- -------------------------------------------------------------------------------- commands for debugger--sprintCmd, printCmd, forceCmd :: String -> GHCi ()-sprintCmd = pprintCommand False False-printCmd = pprintCommand True False-forceCmd = pprintCommand False True--pprintCommand :: Bool -> Bool -> String -> GHCi ()-pprintCommand bind force str = do- pprintClosureCommand bind force str--stepCmd :: String -> GHCi ()-stepCmd arg = withSandboxOnly ":step" $ step arg- where- step [] = doContinue (const True) GHC.SingleStep- step expression = runStmt expression GHC.SingleStep >> return ()--stepLocalCmd :: String -> GHCi ()-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 loc -> do- md <- fromJust <$> getCurrentBreakModule- current_toplevel_decl <- enclosingTickSpan md loc- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep--stepModuleCmd :: String -> GHCi ()-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 :: Module -> SrcSpan -> GHCi 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 :: String -> GHCi ()-traceCmd arg- = withSandboxOnly ":trace" $ tr arg- where- tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >> return ()--continueCmd :: String -> GHCi ()-continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion---- doContinue :: SingleStep -> GHCi ()-doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()-doContinue pre step = do- runResult <- resume pre step- _ <- afterRunStmt pre runResult- return ()--abandonCmd :: String -> GHCi ()-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 :: String -> GHCi ()-deleteCmd argLine = withSandboxOnly ":delete" $ do- deleteSwitch $ words argLine- where- deleteSwitch :: [String] -> GHCi ()- 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 :: String -> GHCi ()- deleteOneBreak str- | all isDigit str = deleteBreak (read str)- | otherwise = return ()--historyCmd :: String -> GHCi ()-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 :: String -> GHCi ()-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 :: String -> GHCi ()-forwardCmd arg- | null arg = forward 1- | all isDigit arg = forward (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :back [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 :: String -> GHCi ()-breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine--breakSwitch :: [String] -> GHCi ()-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- wantNameFromInterpretedModule noCanDo arg1 $ \name -> do- maybe_info <- GHC.getModuleInfo (GHC.nameModule name)- case maybe_info of- Nothing -> noCanDo name (ptext (sLit "cannot get module info"))- Just minf ->- ASSERT( isExternalName name )- findBreakAndSet (GHC.nameModule name) $- findBreakForBind name (GHC.modInfoModBreaks minf)- where- noCanDo n why = printForUser $- text "cannot set breakpoint on " <> ppr n <> text ": " <> why--breakByModule :: Module -> [String] -> GHCi ()-breakByModule md (arg1:rest)- | all isDigit arg1 = do -- looks like a line number- breakByModuleLine md (read arg1) rest-breakByModule _ _- = breakSyntax--breakByModuleLine :: Module -> Int -> [String] -> GHCi ()-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--breakSyntax :: a-breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")--findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()-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- , breakTick = tick- , onBreakCmd = ""- }- 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 (not a nested declaration)--- (b) that do not have an enclosing breakpoint-findBreakForBind :: Name -> GHC.ModBreaks -> TickArray- -> [(BreakIndex,RealSrcSpan)]-findBreakForBind name modbreaks _ = filter (not . enclosed) ticks- where- ticks = [ (index, span)- | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),- n == occNameString (nameOccName name),- 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 `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"---------------------------------------------------------------------------------- :where--whereCmd :: String -> GHCi ()-whereCmd = noArgs $ do- mstrs <- getCallStackAtCurrentBreakpoint- case mstrs of- Nothing -> return ()- Just strs -> liftIO $ putStrLn (renderStack strs)---------------------------------------------------------------------------------- :list--listCmd :: String -> InputT GHCi ()-listCmd c = listCmd' c--listCmd' :: String -> InputT GHCi ()-listCmd' "" = do- mb_span <- lift 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 :: [String] -> InputT GHCi ()-list2 [arg] | all isDigit arg = do- imports <- GHC.getContext- case iiModules imports of- [] -> liftIO $ putStrLn "No module to list"- (mn : _) -> do- md <- lift $ 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 )- lift $ 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 :: Module -> Int -> InputT GHCi ()-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 -> InputT 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 :: Module -> GHCi 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 :: GHCi ()-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 :: GHCi ()-discardActiveBreakPoints = do- st <- getGHCiState- mapM_ (turnOffBreak.snd) (breaks st)- setGHCiState $ st { breaks = [] }--deleteBreak :: Int -> GHCi ()-deleteBreak identity = do- st <- getGHCiState- let oldLocations = breaks st- (this,rest) = partition (\loc -> fst loc == identity) oldLocations- if null this- then printForUser (text "Breakpoint" <+> ppr identity <+>- text "does not exist")- else do- mapM_ (turnOffBreak.snd) this- setGHCiState $ st { breaks = rest }--turnOffBreak :: BreakLocation -> GHCi ()-turnOffBreak loc = do- (arr, _) <- getModBreak (breakModule loc)- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False--getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)-getModBreak m = do- mod_info <- fromJust <$> GHC.getModuleInfo m- let modBreaks = GHC.modInfoModBreaks mod_info- let arr = GHC.modBreaks_flags modBreaks- let ticks = GHC.modBreaks_locs modBreaks- return (arr, ticks)--setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()-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 arond the flushing operation, so if stderr is closed--- GHCi will just die gracefully rather than going into an infinite loop.-handler :: SomeException -> GHCi Bool--handler exception = do- flushInterpBuffers- withSignalHandlers $- ghciHandle handler (showException exception >> return False)--showException :: SomeException -> GHCi ()-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 = gmask $ \restore -> do- -- Force dflags to avoid leaking the associated HscEnv- !dflags <- getDynFlags- gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)--ghciTry :: GHCi a -> GHCi (Either SomeException a)-ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)--tryBool :: GHCi a -> GHCi 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--isHomeModule :: Module -> Bool-isHomeModule m = GHC.moduleUnitId m == mainUnitId---- TODO: won't work if home dir is encoded.--- (changeDirectory may not work either in that case.)-expandPath :: MonadIO m => String -> InputT 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- when (GHC.moduleUnitId modl /= thisPackage dflags) $- 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
− src-bin-841/Clash/GHCi/UI/Info.hs
@@ -1,366 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}---- | 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.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 CoreUtils-import Desugar-import DynFlags (HasDynFlags(..))-import FastString-import GHC-import GhcMonad-import Name-import NameSet-import Outputable-import SrcLoc-import TcHsSyn-import 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- }---- | 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.- }---- | 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 = RealSrcSpan . spaninfoSrcSpan- 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 (moduleUnitId 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) }- `gcatch`- (\(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 = ml_obj_file (ms_location (modinfoSummary mi))- last' = modinfoLastUpdate mi- exists <- doesFileExist fp- if exists- then (> last') <$> getModificationTime fp- else return True---- | 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- now <- liftIO getCurrentTime- return (ModInfo m allTypes i now)---- | 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 _ _ _typ _})- = 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, CoreUtils.exprType expr)) mbe- where- mid :: Maybe Id- mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i- | otherwise = Nothing-- unwrapVar (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-841/Clash/GHCi/UI/Monad.hs
@@ -1,475 +0,0 @@-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}--{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- Monadery code used in InteractiveUI------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module Clash.GHCi.UI.Monad (- GHCi(..), startGHCi,- GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,- GHCiOption(..), isOptionSet, setOption, unsetOption,- Command(..),- PromptFunction,- BreakLocation(..),- TickArray,- getDynFlags,-- runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,-- printForUserNeverQualify, printForUserModInfo,- printForUser, printForUserPartWay, prettyLocations,- initInterpBuffering,- turnOffBuffering, turnOffBuffering_,- flushInterpBuffers,- mkEvalWrapper- ) where--#include "../HsVersions.h"--import Clash.GHCi.UI.Info (ModInfo)-import qualified GHC-import GhcMonad hiding (liftIO)-import Outputable hiding (printForUser, printForUserPartWay)-import qualified Outputable-import DynFlags-import FastString-import HscTypes-import SrcLoc-import Module-import GHCi-import GHCi.RemoteTypes-import HsSyn (ImportDecl, GhcPs)-import Util--import Exception-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 qualified System.Console.Haskeline as Haskeline-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Data.Map.Strict (Map)-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,- options :: [GHCiOption],- line_number :: !Int, -- ^ input line- break_ctr :: !Int,- breaks :: ![(Int, 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- 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- }--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--data BreakLocation- = BreakLocation- { breakModule :: !GHC.Module- , breakLoc :: !SrcSpan- , breakTick :: {-# UNPACK #-} !Int- , onBreakCmd :: String- }--instance Eq BreakLocation where- loc1 == loc2 = breakModule loc1 == breakModule loc2 &&- breakTick loc1 == breakTick loc2--prettyLocations :: [(Int, BreakLocation)] -> SDoc-prettyLocations [] = text "No active breakpoints."-prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs--instance Outputable BreakLocation where- ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>- if null (onBreakCmd loc)- then Outputable.empty- else doubleQuotes (text (onBreakCmd loc))--recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)-recordBreak brkLoc = do- st <- getGHCiState- let oldActiveBreaks = breaks st- -- 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 = (oldCounter, brkLoc) : oldActiveBreaks- }- return (False, oldCounter)--newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }--reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a-reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s--reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a-reifyGHCi f = GHCi f'- where- -- f' :: IORef GHCiState -> Ghc a- f' gs = reifyGhc (f'' gs)- -- f'' :: IORef GHCiState -> Session -> IO a- f'' gs s = f (s, gs)--startGHCi :: GHCi a -> GHCiState -> Ghc a-startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref--instance Functor GHCi where- fmap = liftM--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 HasGhciState m where- getGHCiState :: m GHCiState- setGHCiState :: GHCiState -> m ()- modifyGHCiState :: (GHCiState -> GHCiState) -> m ()--instance HasGhciState GHCi where- getGHCiState = GHCi $ \r -> liftIO $ readIORef r- setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s- modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f--instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where- getGHCiState = lift getGHCiState- setGHCiState = lift . setGHCiState- modifyGHCiState = lift . modifyGHCiState--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--instance ExceptionMonad GHCi where- gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)- gmask f =- GHCi $ \s -> gmask $ \io_restore ->- let- g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')- in- unGHCi (f g_restore) s--instance Haskeline.MonadException Ghc where- controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)- in fmap (flip unGhc s) $ f run'--instance Haskeline.MonadException GHCi where- controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)- in fmap (flip unGHCi s) $ f run'--instance ExceptionMonad (InputT GHCi) where- gcatch = Haskeline.catch- gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)--isOptionSet :: GHCiOption -> GHCi Bool-isOptionSet opt- = do st <- getGHCiState- return (opt `elem` options st)--setOption :: GHCiOption -> GHCi ()-setOption opt- = do st <- getGHCiState- setGHCiState (st{ options = opt : filter (/= opt) (options st) })--unsetOption :: GHCiOption -> GHCi ()-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 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 doc--printForUser :: GhcMonad m => SDoc -> m ()-printForUser doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUserPartWay :: SDoc -> GHCi ()-printForUserPartWay doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc---- | Run a single Haskell expression-runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt expr 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 expr opts--runDecls :: String -> GHCi (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)--resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi 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--timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a-timeIt getAllocs action- = do b <- lift $ isOptionSet ShowTiming- if not b- then action- else do time1 <- liftIO $ getCurrentTime- a <- action- let allocs = getAllocs a- time2 <- liftIO $ getCurrentTime- dflags <- getDynFlags- let period = time2 `diffUTCTime` time1- liftIO $ printTimes dflags allocs (realToFrac period)- return a--printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()-printTimes dflags mallocs 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 :: GHCi ()-revertCAFs = do- liftIO rts_revertCAFs- s <- getGHCiState- when (not (ghc_e s)) turnOffBuffering- -- Have to turn off buffering again, because we just- -- reverted stdout, stderr & stdin to their defaults.--foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()- -- Make it "safe", just in case---------------------------------------------------------------------------------- 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- nobuf <- compileGHCiExpr $- "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++- " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++- " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"- flush <- compileGHCiExpr $- "do { System.IO.hFlush System.IO.stdout; " ++- " System.IO.hFlush System.IO.stderr }"- return (nobuf, flush)---- | Invoke "hFlush stdout; hFlush stderr" in the interpreter-flushInterpBuffers :: GHCi ()-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 :: GHCi ()-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 =- compileGHCiExpr $- "\\m -> System.Environment.withProgName " ++ show progname ++- "(System.Environment.withArgs " ++ show args ++ " m)"--compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue-compileGHCiExpr expr = do- hsc_env <- getSession- let dflags = hsc_dflags hsc_env- -- RebindableSyntax can wreak havoc with GHCi in several ways- -- (see #13385 and #14342 for examples), so we take care to disable it- -- for the duration of running expressions that are internal to GHCi.- no_rb_hsc_env =- hsc_env { hsc_dflags = xopt_unset dflags LangExt.RebindableSyntax }- setSession no_rb_hsc_env- res <- GHC.compileExprRemote expr- setSession hsc_env- pure res
− src-bin-841/Clash/GHCi/UI/Tags.hs
@@ -1,216 +0,0 @@------------------------------------------------------------------------------------ GHCi's :ctags and :etags commands------ (c) The GHC Team 2005-2007-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--module Clash.GHCi.UI.Tags (- createCTagsWithLineNumbersCmd,- createCTagsWithRegExesCmd,- createETagsFileCmd-) where--import Exception-import GHC-import Clash.GHCi.UI.Monad-import Outputable---- ToDo: figure out whether we need these, and put something appropriate--- into the GHC API instead-import Name (nameOccName)-import OccName (pprOccName)-import ConLike-import MonadUtils--import Data.Function-import Data.Maybe-import Data.Ord-import DriverPhases-import Panic-import Data.List-import Control.Monad-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-841/Clash/Main.hs
@@ -1,1042 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}------------------------------------------------------------------------------------- GHC Driver program------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module Clash.Main (defaultMain, defaultMainWithAction) where---- For Int/Word size-#include "MachDeps.h"---- The official GHC API-import qualified GHC-import GHC ( -- DynFlags(..), HscTarget(..),- -- GhcMode(..), GhcLink(..),- Ghc, GhcMonad(..),- LoadHowMuch(..) )-import CmdLineParser---- Implementations of the various modes (--show-iface, mkdependHS. etc.)-import LoadIface ( showIface )-import HscMain ( newHscEnv )-import DriverPipeline ( oneShot, compileFile )-import DriverMkDepend ( doMkDependHS )-import DriverBkp ( doBackpack )-#if defined(GHCI)-import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )-#endif---- Frontend plugins-#if defined(GHCI)-import DynamicLoading ( loadFrontendPlugin )-import Plugins-#else-import DynamicLoading ( pluginError )-#endif-import Module ( ModuleName )----- Various other random stuff that we need-import Config-import Constants-import HscTypes-import Packages ( pprPackages, pprPackagesSimple )-import DriverPhases-import BasicTypes ( failed )-import DynFlags hiding (WarnReason(..))-import ErrUtils-import FastString-import Outputable-import SrcLoc-import Util-import Panic-import UniqSupply-import MonadUtils ( liftIO )---- Imports for --abi-hash-import LoadIface ( loadUserInterface )-import Module ( mkModuleName )-import Finder ( findImportedModule, cannotFindModule )-import TcRnMonad ( initIfaceCheck )-import Binary ( openBinMem, put_ )-import BinFingerprint ( fingerprintBinMem )---- Standard Haskell libraries-import System.IO-import System.Environment-import System.Exit-import System.FilePath-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe---- clash additions-import Paths_clash_ghc-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)---------------------------------------------------------------------------------- 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-- -- Handle GHC-specific character encoding flags, allowing us to control how- -- GHC produces output regardless of OS.- env <- getEnvironment- case lookup "GHC_CHARENC" env of- Just "UTF-8" -> do- hSetEncoding stdout utf8- hSetEncoding stderr utf8- _ -> do- -- Avoid GHC erroring out when trying to display unhandled characters- hSetTranslit stdout- hSetTranslit stderr-- 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 argv2 = map (mkGeneralLocated "on the commandline") argv1- libDir <- ghcLibDir-- let argv1 = map (mkGeneralLocated "on the commandline") argv0- r <- newIORef defClashOpts-- (argv2, clashFlagWarnings) <- parseClashFlags r argv1-- -- 2. Parse the "mode" flags (--make, --interactive etc.)- -- (mode, argv3, flagWarnings) <- parseModeFlags argv2- (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- ShowVersion -> showVersion- ShowNumVersion -> putStrLn cProjectVersion- ShowOptions isInteractive -> showOptions isInteractive r- 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 overriden 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 = updateWays $ dflags3 { ways = interpWays }- dflags3b = foldl gopt_set dflags3a- $ concatMap (wayGeneralFlags platform)- interpWays- dflags3c = foldl gopt_unset dflags3b- $ concatMap (wayUnsetGeneralFlags platform)- interpWays- 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 - e.g., for win32 platforms, backslashes are converted- -- into forward slashes.- normal_fileish_paths = map (normalise . 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 $ dumpPackagesSimple dflags6- | v >= 5 -> liftIO $ dumpPackages 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 = gcatch (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 srcs Nothing- DoEval exprs -> ghciUI clashOpts srcs $ Just $ reverse exprs- DoAbiHash -> abiHash (map fst srcs)- ShowPackages -> liftIO $ showPackages dflags6- DoFrontend f -> doFrontend f srcs- DoVHDL -> clash makeVHDL- DoVerilog -> clash makeVerilog- DoSystemVerilog -> clash makeSystemVerilog- DoBackpack -> doBackpack (map fst srcs)-- liftIO $ dumpFinalStats dflags6--ghciUI :: IORef ClashOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()-#if !defined(GHCI)-ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")-#else-ghciUI opts = interactiveUI (defaultGhciSettings opts)-#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 (notNull (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 ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)- && 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"- _ -> 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, showPackagesMode, doVHDLMode, doVerilogMode,- doSystemVerilogMode :: Mode-doMkDependHSMode = mkPostLoadMode DoMkDependHS-doMakeMode = mkPostLoadMode DoMake-doInteractiveMode = mkPostLoadMode DoInteractive-doAbiHashMode = mkPostLoadMode DoAbiHash-showPackagesMode = 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(GHCI)-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 showPackagesMode))- ] ++- [ 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(GHCI)- -- 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--showSupportedExtensions :: IO ()-showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions--showVersion :: IO ()-showVersion = putStrLn $ concat [ "Clash, version "- , Data.Version.showVersion Paths_clash_ghc.version- , " (using clash-lib, version: "- , Data.Version.showVersion clashLibVersion- , ")"- ]--showOptions :: Bool -> IORef ClashOpts -> IO ()-showOptions isInteractive = putStr . unlines . availableOptions- where- availableOptions opts = concat- [ flagsForCompletion isInteractive- , map ('-':) (getFlagNames mode_flags)- , map ('-':) (getFlagNames (flagsClash opts))- ]- 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- buckets <- getFastStringTable- let (entries, longest, has_z) = countFS 0 0 0 buckets- msg = text "FastString stats:" $$- nest 4 (vcat [text "size: " <+> int (length buckets),- text "entries: " <+> int entries,- text "longest chain: " <+> int longest,- text "has z-encoding: " <+> (has_z `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 '%'--countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)-countFS entries longest has_z [] = (entries, longest, has_z)-countFS entries longest has_z (b:bs) =- let- len = length b- longest' = max len longest- entries' = entries + len- has_zs = length (filter hasZEncoding b)- in- countFS entries' longest' (has_z + has_zs) bs--showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()-showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))-dumpPackages dflags = putMsg dflags (pprPackages dflags)-dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)---- -------------------------------------------------------------------------------- Frontend plugin support--doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()-#if !defined(GHCI)-doFrontend modname _ = pluginError [modname]-#else-doFrontend modname srcs = do- hsc_env <- getSession- frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname- frontend frontend_plugin- (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs-#endif---- -------------------------------------------------------------------------------- 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 chagnes, 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 (Trac #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 False (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) ifaces- f <- fingerprintBinMem bh-- putStrLn (showPpr dflags f)---------------------------------------------------------------------------------- VHDL 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 :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState)--makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState)--makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> 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 initalize 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.--}--foreign import ccall safe "initGCStatistics"- initGCStatistics :: IO ()
src-bin-861/Clash/GHCi/UI.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-}@@ -94,11 +93,11 @@ 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, partition, sort, sortBy )+import Data.Proxy import qualified Data.Set as S import Data.Maybe import Data.Map (Map)@@ -140,31 +139,23 @@ import Clash.GHCi.Leak -- clash additions-import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend(initBackend, hdlKind, primDirs)) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver-import Clash.Driver.Types (ClashOpts(..))+import Clash.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..)) -#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 {@@ -1977,11 +1968,13 @@ 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'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi () makeHDL' backend opts lst = go =<< case lst of srcs@(_:_) -> return srcs [] -> do@@ -2017,27 +2010,21 @@ _ <- GHC.setSessionDynFlags dflags reloadModule "" -makeHDL :: GHC.GhcMonad m- => Clash.Backend.Backend backend- => (Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> backend)- -> GHC.Ghc ()- -> IORef ClashOpts- -> [FilePath]- -> m ()-makeHDL backend startAction optsRef srcs = do+makeHDL+ :: forall backend m+ . (GHC.GhcMonad m, Backend backend)+ => Proxy backend+ -> GHC.Ghc ()+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL Proxy startAction optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef let opts1 = opts0 { opt_color = useColor dflags } 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'+ hdl = hdlKind backend -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags hidir <- hiDir dflags@@ -2049,52 +2036,42 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc lw frcUdf (coerce xOptBB)+ backend = initBackend @backend opts2 checkMonoLocalBinds dflags checkImportDirs opts0 idirs - primDirs <- Clash.Backend.primDirs backend'+ primDirs_ <- primDirs backend forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile 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+ (clashEnv, clashDesign) <- generateBindings opts2 startAction primDirs_ idirs dbs hdl src (Just dflags)+ let getMain = getMainTopEntity src clashDesign mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)- prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ prepTime <- startTime `deepseq` designBindings clashDesign `deepseq` envTyConMap clashEnv `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+ clashEnv+ clashDesign+ (Just backend)+ (ghcTypeToHWType iw) ghcEvaluator-#else evaluator-#endif- topEntities mainTopEntity- opts2- (startTime,prepTime)+ startTime makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
src-bin-861/Clash/GHCi/UI/Monad.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
src-bin-861/Clash/Main.hs view
@@ -53,6 +53,7 @@ import DriverPhases import BasicTypes ( failed ) import DynFlags hiding (WarnReason(..))+import EnumSet as EnumSet import ErrUtils import FastString import Outputable@@ -79,25 +80,23 @@ import Control.Monad import Data.Char import Data.List+import Data.Proxy import Data.Maybe -- clash additions import Paths_clash_ghc import Clash.GHCi.UI (makeHDL) import Exception (gcatch)-import Data.IORef (IORef, newIORef, readIORef)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef') import qualified Data.Version (showVersion) -import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend) 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)@@ -237,6 +236,10 @@ (dflags3, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags2 args + -- Propagate -Werror to Clash+ liftIO . modifyIORef' clashOpts $ \opts ->+ opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }+ let dflags4 = case lang of HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> let platform = targetPlatform dflags3@@ -973,19 +976,25 @@ ----------------------------------------------------------------------------- -- 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+makeHDL'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap fst srcs makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> PreserveCase -> Maybe (Maybe Int) -> AggressiveXOptBB -> SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
src-bin-881/Clash/GHCi/UI.hs view
@@ -95,12 +95,12 @@ 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 ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy )+import Data.Proxy import qualified Data.Set as S import Data.Maybe import Data.Map (Map)@@ -142,31 +142,22 @@ import Clash.GHCi.Leak -- clash additions-import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend(initBackend, hdlKind, primDirs)) import Clash.Backend.SystemVerilog (SystemVerilogState) import Clash.Backend.VHDL (VHDLState) import Clash.Backend.Verilog (VerilogState) import qualified Clash.Driver-import Clash.Driver.Types (ClashOpts(..))+import Clash.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..)) -#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 {@@ -2068,11 +2059,13 @@ 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'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi () makeHDL' backend opts lst = go =<< case lst of srcs@(_:_) -> return srcs [] -> do@@ -2108,27 +2101,21 @@ _ <- 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+makeHDL+ :: forall backend m+ . (GHC.GhcMonad m, Backend backend)+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL Proxy 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'+ hdl = hdlKind backend -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags hidir <- hiDir dflags@@ -2140,53 +2127,43 @@ idirs = importPaths dflags opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1) , opt_importPaths = idirs}- backend' = backend iw syn esc lw frcUdf (coerce xOptBB)+ backend = initBackend @backend opts2 checkMonoLocalBinds dflags checkImportDirs opts0 idirs - primDirs <- Clash.Backend.primDirs backend'+ primDirs_ <- primDirs backend forM_ srcs $ \src -> do -- Generate bindings: let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]- (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs,domainConfs) <-- generateBindings startAction color primDirs idirs dbs hdl src (Just dflags)+ (clashEnv, clashDesign) <- generateBindings opts2 startAction primDirs_ idirs dbs hdl src (Just dflags) - let getMain = getMainTopEntity src bindingsMap topEntities+ let getMain = getMainTopEntity src clashDesign mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)- prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ prepTime <- startTime `deepseq` designBindings clashDesign `deepseq` envTyConMap clashEnv `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+ clashEnv+ clashDesign+ (Just backend)+ (ghcTypeToHWType iw) ghcEvaluator-#else evaluator-#endif- topEntities mainTopEntity- opts2- (startTime,prepTime)+ startTime makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
src-bin-881/Clash/Main.hs view
@@ -50,6 +50,7 @@ import DriverPhases import BasicTypes ( failed ) import DynFlags hiding (WarnReason(..))+import EnumSet as EnumSet import ErrUtils import FastString import Outputable@@ -76,25 +77,23 @@ import Control.Monad import Data.Char import Data.List+import Data.Proxy import Data.Maybe -- clash additions import Paths_clash_ghc import Clash.GHCi.UI (makeHDL) import Exception (gcatch)-import Data.IORef (IORef, newIORef, readIORef)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef') import qualified Data.Version (showVersion) -import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend) 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)@@ -232,6 +231,10 @@ (dflags3, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags2 args + -- Propagate -Werror to Clash+ liftIO . modifyIORef' clashOpts $ \opts ->+ opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }+ let dflags4 = case lang of HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> let platform = targetPlatform dflags3@@ -981,20 +984,24 @@ -- 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+ :: forall backend+ . Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap fst srcs makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
src-bin-9.0/Clash/GHCi/UI.hs view
@@ -105,6 +105,7 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( elemIndices, find, group, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )+import Data.Proxy import qualified Data.Set as S import Data.Maybe import Data.Map (Map)@@ -147,31 +148,21 @@ import Clash.GHCi.Leak -- clash additions-import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend(initBackend, hdlKind, primDirs)) 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.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..)) import Clash.GHC.Evaluator-#endif- import Clash.GHC.GenerateBindings import Clash.GHC.NetlistTypes+import Clash.GHC.PartialEval 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 {@@ -2185,11 +2176,13 @@ 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'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi () makeHDL' backend opts lst = go =<< case lst of srcs@(_:_) -> return srcs [] -> do@@ -2225,27 +2218,21 @@ _ <- 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+makeHDL+ :: forall backend m+ . (GHC.GhcMonad m, Backend backend)+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL Proxy 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'+ hdl = hdlKind backend -- determine whether `-outputdir` was used outputDir = do odir <- objectDir dflags hidir <- hiDir dflags@@ -2257,53 +2244,43 @@ 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)+ backend = initBackend @backend opts2 checkMonoLocalBinds dflags checkImportDirs opts0 idirs - primDirs <- Clash.Backend.primDirs backend'+ primDirs_ <- 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)+ (clashEnv, clashDesign) <- generateBindings opts2 startAction primDirs_ idirs dbs hdl src (Just dflags) - let getMain = getMainTopEntity src bindingsMap topEntities+ let getMain = getMainTopEntity src clashDesign mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)- prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ prepTime <- startTime `deepseq` designBindings clashDesign `deepseq` envTyConMap clashEnv `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+ clashEnv+ clashDesign+ (Just backend)+ (ghcTypeToHWType iw) ghcEvaluator-#else evaluator-#endif- topEntities mainTopEntity- opts2- (startTime,prepTime)+ startTime makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) ----------------------------------------------------------------------------- -- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
src-bin-9.0/Clash/GHCi/UI/Info.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing -Wno-compat-unqualified-imports #-} -- | Get information on modules, expressions, and identifiers
src-bin-9.0/Clash/Main.hs view
@@ -54,6 +54,7 @@ import GHC.Types.Basic ( failed ) import GHC.Driver.Session as DynFlags hiding (WarnReason(..)) import GHC.Utils.Error+import GHC.Data.EnumSet as EnumSet import GHC.Data.FastString import GHC.Utils.Outputable as Outputable import GHC.SysTools.BaseDir@@ -81,6 +82,7 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.Char import Data.List ( isPrefixOf, partition, intercalate, nub )+import Data.Proxy import qualified Data.Set as Set import Data.Maybe import Prelude@@ -89,19 +91,16 @@ import Paths_clash_ghc import Clash.GHCi.UI (makeHDL) import Control.Monad.Catch (catch)-import Data.IORef (IORef, newIORef, readIORef)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef') import qualified Data.Version (showVersion) -import qualified Clash.Backend-import Clash.Backend (AggressiveXOptBB)+import Clash.Backend (Backend) 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)@@ -239,6 +238,10 @@ (dflags3, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags2 args + -- Propagate -Werror to Clash+ liftIO . modifyIORef' clashOpts $ \opts ->+ opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }+ let dflags4 = case lang of HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> let platform = targetPlatform dflags3@@ -1005,20 +1008,24 @@ -- 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+ :: forall backend+ . Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap fst srcs makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)+makeVHDL = makeHDL' (Proxy @VHDLState) makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)+makeVerilog = makeHDL' (Proxy @VerilogState) makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
src-bin-common/Clash/GHCi/Common.hs view
@@ -1,5 +1,5 @@ {-|- Copyright : (C) 2021, QBayLogic+ Copyright : (C) 2021-2022, QBayLogic License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -}@@ -17,7 +17,7 @@ ) where -- Clash-import Clash.Driver.Types (ClashOpts (..), BindingMap)+import Clash.Driver.Types (ClashOpts (..), ClashDesign(..)) import Clash.Netlist.Types (TopEntityT(..)) -- The GHC interface@@ -36,13 +36,14 @@ import Clash.Core.Var (varName) import Clash.Normalize.Util (collectCallGraphUniques, callGraph) import qualified Clash.Util.Interpolate as I-import Clash.Util (ClashException(..), HasCallStack, noSrcSpan)+import Clash.Util (ClashException(..), noSrcSpan) import Clash.Unique (getUnique) import Control.Exception (throw) import Data.List (isSuffixOf) import qualified Data.Text as Text import qualified Data.HashSet as HashSet import qualified GHC.LanguageExtensions as LangExt (Extension (..))+import GHC.Stack (HasCallStack) import Control.Monad (forM_, unless, when) import System.Directory (doesDirectoryExist)@@ -52,27 +53,25 @@ :: HasCallStack => String -- ^ Module name- -> BindingMap- -- ^ Map of global binders- -> [TopEntityT]- -- ^ List of top entities loaded by LoadModules+ -> ClashDesign -> String -- ^ string passed with -main-is -> IO (TopEntityT, [TopEntityT]) -- ^ Throws exception if -main-is was set, but no such top entity was found. -- Otherwise, returns main top entity and all top entities (transitively) used -- in the main top entity.-getMainTopEntity modName bindingMap topEnts nm =- case filter isNm topEnts of+getMainTopEntity modName design nm =+ case filter isNm (designEntities design) of [] -> throw $ ClashException noSrcSpan [I.i| Could not find top entity called #{show nm} in #{show modName} |] Nothing [t] -> let+ bindingMap = designBindings design closure0 = collectCallGraphUniques (callGraph bindingMap (topId t)) closure1 = HashSet.delete (getUnique (topId t)) closure0 in- pure (t, filter ((`HashSet.member` closure1) . getUnique . topId) topEnts)+ pure (t, filter ((`HashSet.member` closure1) . getUnique . topId) (designEntities design)) ts -> error $ [I.i| Internal error: multiple top entities called #{nm} (#{map topId ts})
src-ghc/Clash/GHC/ClashFlags.hs view
@@ -1,12 +1,12 @@ {-| Copyright : (C) 2015-2016, University of Twente,- 2016-2017, Myrtle Software Ltd+ 2016-2017, Myrtle Software Ltd,+ 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} module Clash.GHC.ClashFlags ( parseClashFlags@@ -38,31 +38,16 @@ import Clash.Netlist.Types (PreserveCase (ToLower)) parseClashFlags :: IORef ClashOpts -> [Located String]- -> IO ([Located String]-#if MIN_VERSION_ghc(8,4,1)- ,[Warn])-#else- ,[Located String])-#endif+ -> IO ([Located String],[Warn]) parseClashFlags r = parseClashFlagsFull (flagsClash r) parseClashFlagsFull :: [Flag IO] -> [Located String]- -> IO ([Located String]-#if MIN_VERSION_ghc(8,4,1)- ,[Warn])-#else- ,[Located String])-#endif+ -> IO ([Located String],[Warn]) parseClashFlagsFull flagsAvialable args = do (leftovers,errs,warns) <- processArgs flagsAvialable args unless (null errs) $ throwGhcExceptionIO $- errorsToGhcException . map (("on the commandline", ) .-#if MIN_VERSION_ghc(8,4,1)- unLoc . errMsg)-#else- unLoc)-#endif+ errorsToGhcException . map (("on the commandline", ) . unLoc . errMsg) $ errs return (leftovers, warns)@@ -70,9 +55,12 @@ flagsClash :: IORef ClashOpts -> [Flag IO] flagsClash r = [ defFlag "fclash-debug" $ SepArg (setDebugLevel r)+ , defFlag "fclash-debug-info" $ SepArg (setDebugInfo r)+ , defFlag "fclash-debug-invariants" $ NoArg (liftEwM (setDebugInvariants r))+ , defFlag "fclash-debug-count-transformations" $ NoArg (liftEwM (setDebugCountTransformations r)) , 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-transformations-from" $ IntSuffix (setDebugTransformationsFrom r)+ , defFlag "fclash-debug-transformations-limit" $ IntSuffix (setDebugTransformationsLimit r) , defFlag "fclash-debug-history" $ AnySuffix (liftEwM . (setRewriteHistoryFile r)) , defFlag "fclash-hdldir" $ SepArg (setHdlDir r) , defFlag "fclash-hdlsyn" $ SepArg (setHdlSyn r)@@ -89,7 +77,7 @@ , 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-float-support" $ NoArg (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))@@ -100,6 +88,7 @@ , 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))+ , defFlag "fclash-no-render-enums" $ NoArg (liftEwM (setNoRenderEnums r)) ] -- | Print deprecated flag warning@@ -152,32 +141,93 @@ -> IO () setSpecLimit r n = modifyIORef r (\c -> c {opt_specLimit = n}) +setDebugInvariants :: IORef ClashOpts -> IO ()+setDebugInvariants r =+ modifyIORef r $ \c ->+ c { opt_debug = (opt_debug c) { dbg_invariants = True } }++setDebugCountTransformations :: IORef ClashOpts -> IO ()+setDebugCountTransformations r =+ modifyIORef r $ \c ->+ c { opt_debug = (opt_debug c) { dbg_countTransformations = True } }+ setDebugTransformations :: IORef ClashOpts -> String -> EwM IO () setDebugTransformations r s =- liftEwM (modifyIORef r (\c -> c {opt_dbgTransformations = transformations}))+ liftEwM (modifyIORef r (setTransformations transformations)) where transformations = Set.fromList (filter (not . null) (map trim (splitOn "," s))) trim = dropWhileEnd isSpace . dropWhile isSpace -setDebugTransformationsFrom :: IORef ClashOpts -> Maybe Int -> EwM IO ()-setDebugTransformationsFrom r (Just n) =- liftEwM (modifyIORef r (\c -> c {opt_dbgTransformationsFrom = n}))-setDebugTransformationsFrom _r Nothing = pure ()+ setTransformations xs opts =+ opts { opt_debug = (opt_debug opts) { dbg_transformations = xs } } -setDebugTransformationsLimit :: IORef ClashOpts -> Maybe Int -> EwM IO ()-setDebugTransformationsLimit r (Just n) =- liftEwM (modifyIORef r (\c -> c {opt_dbgTransformationsLimit = n}))-setDebugTransformationsLimit _r Nothing = pure ()+setDebugTransformationsFrom :: IORef ClashOpts -> Int -> EwM IO ()+setDebugTransformationsFrom r n =+ liftEwM (modifyIORef r (setFrom (fromIntegral n)))+ where+ setFrom from opts =+ opts { opt_debug = (opt_debug opts) { dbg_transformationsFrom = Just from } } -setDebugLevel :: IORef ClashOpts- -> String- -> EwM IO ()-setDebugLevel r s = case readMaybe s of- Just dbgLvl -> liftEwM $ do- modifyIORef r (\c -> c {opt_dbgLevel = dbgLvl})- when (dbgLvl > DebugNone) $ setNoCache r -- when debugging disable cache- Nothing -> addWarn (s ++ " is an invalid debug level")+setDebugTransformationsLimit :: IORef ClashOpts -> Int -> EwM IO ()+setDebugTransformationsLimit r n =+ liftEwM (modifyIORef r (setLimit (fromIntegral n)))+ where+ setLimit limit opts =+ opts { opt_debug = (opt_debug opts) { dbg_transformationsLimit = Just limit } } +setDebugLevel :: IORef ClashOpts -> String -> EwM IO ()+setDebugLevel r s =+ case s of+ "DebugNone" ->+ liftEwM $ modifyIORef r (setLevel debugNone)+ "DebugSilent" ->+ liftEwM $ do+ modifyIORef r (setLevel debugSilent)+ setNoCache r+ "DebugFinal" ->+ liftEwM $ do+ modifyIORef r (setLevel debugFinal)+ setNoCache r+ "DebugCount" ->+ liftEwM $ do+ modifyIORef r (setLevel debugCount)+ setNoCache r+ "DebugName" ->+ liftEwM $ do+ modifyIORef r (setLevel debugName)+ setNoCache r+ "DebugTry" ->+ liftEwM $ do+ modifyIORef r (setLevel debugTry)+ setNoCache r+ "DebugApplied" ->+ liftEwM $ do+ modifyIORef r (setLevel debugApplied)+ setNoCache r+ "DebugAll" ->+ liftEwM $ do+ modifyIORef r (setLevel debugAll)+ setNoCache r+ _ ->+ addWarn (s ++ " is an invalid debug level")+ where+ setLevel lvl opts =+ opts { opt_debug = lvl }++setDebugInfo :: IORef ClashOpts -> String -> EwM IO ()+setDebugInfo r s =+ case readMaybe s of+ Just info ->+ liftEwM $ do+ modifyIORef r (setInfo info)+ when (info /= None) (setNoCache r)++ Nothing ->+ addWarn (s ++ " is an invalid debug info")+ where+ setInfo info opts =+ opts { opt_debug = (opt_debug opts) { dbg_transformationInfo = info } }+ setNoCache :: IORef ClashOpts -> IO () setNoCache r = modifyIORef r (\c -> c {opt_cachehdl = False}) @@ -221,8 +271,9 @@ setErrorExtra :: IORef ClashOpts -> IO () setErrorExtra r = modifyIORef r (\c -> c {opt_errorExtra = True}) -setFloatSupport :: IORef ClashOpts -> IO ()-setFloatSupport r = modifyIORef r (\c -> c {opt_floatSupport = True})+setFloatSupport :: IORef ClashOpts -> EwM IO ()+setFloatSupport _ =+ addWarn "Deprecated flag: -fclash-float-support is always enabled from Clash 1.6 and onwards" setComponentPrefix :: IORef ClashOpts@@ -267,4 +318,10 @@ let fileNm = case drop (length "-fclash-debug-history=") arg of [] -> "history.dat" str -> str- modifyIORef r (\c -> c {opt_dbgRewriteHistoryFile = Just fileNm})+ modifyIORef r (setFile fileNm)+ where+ setFile file opts =+ opts { opt_debug = (opt_debug opts) { dbg_historyFile = Just file } }++setNoRenderEnums :: IORef ClashOpts -> IO ()+setNoRenderEnums r = modifyIORef r (\c -> c { opt_renderEnums = False })
src-ghc/Clash/GHC/Evaluator.hs view
@@ -1,7 +1,8 @@ {-|- Copyright : (C) 2017, Google Inc.+ Copyright : (C) 2017, Google Inc.,+ 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> Call-by-need evaluator based on the evaluator described in: @@ -35,19 +36,20 @@ import Clash.Core.DataCon import Clash.Core.Evaluator.Types-import Clash.Core.FreeVars+import Clash.Core.HasFreeVars+import Clash.Core.HasType 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 qualified Clash.Normalize.Primitives as NP (undefined) import Clash.Unique import Clash.Util (curLoc) @@ -177,7 +179,7 @@ in Just . setTerm x $ stackPush (Apply n) m0 where (term, args, _) = collectArgsTicks (App x y)- tys' = fst . splitFunForallTy . termType tcm $ App x y+ tys' = fst . splitFunForallTy . inferCoreTypeOf tcm $ App x y stepTyApp :: Term -> Type -> Step stepTyApp x ty m tcm =@@ -193,8 +195,8 @@ 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" ] ->+ [] | primName p `elem` [ "Clash.Normalize.Primitives.removedArg"+ , "Clash.Normalize.Primitives.undefined" ] -> ghcUnwind (PrimVal p (rights args) []) m tcm | otherwise ->@@ -209,10 +211,11 @@ _ -> Just . setTerm x $ stackPush (Instantiate ty) m where (term, args, _) = collectArgsTicks (TyApp x ty)- tys' = fst . splitFunForallTy . termType tcm $ TyApp x ty+ tys' = fst . splitFunForallTy . inferCoreTypeOf tcm $ TyApp x ty -stepLetRec :: [LetBinding] -> Term -> Step-stepLetRec bs x m _ = Just (allocate bs x m)+stepLet :: Bind Term -> Term -> Step+stepLet (NonRec i b) x m _ = Just (allocate [(i,b)] x m)+stepLet (Rec bs) x m _ = Just (allocate bs x m) stepCase :: Term -> Type -> [Alt] -> Step stepCase scrut ty alts m _ =@@ -243,7 +246,7 @@ 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+ Let bs x -> stepLet 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@@ -280,7 +283,7 @@ = let m' = heapInsert LocalId id_ e m in (m' { mSupply = ids', mScopeNames = is1 }, id_) where- ty = termType tcm e+ ty = inferCoreTypeOf tcm e ((ids', is1), id_) = mkUniqSystemId (mSupply m, mScopeNames m) ("x", ty) -- | Unwind the stack by 1@@ -310,9 +313,9 @@ subst0 = mkSubst $ extendInScopeSet (mScopeNames m) x apply tcm pVal@(PrimVal (PrimInfo{primType}) tys vs) x m | isUndefinedPrimVal pVal- = setTerm (undefinedTm ty) m+ = setTerm (TyApp (Prim NP.undefined) ty) m where- ty = piResultTys tcm primType (tys ++ map (termType tcm . valToTerm) vs ++ [varType x])+ ty = piResultTys tcm primType (tys ++ map (inferCoreTypeOf tcm . valToTerm) vs ++ [varType x]) apply _ v _ m = error $ "Evaluator.apply: Not a lambda: " ++ show v ++ "\n" ++ show m @@ -323,10 +326,10 @@ where subst = extendTvSubst subst0 x ty subst0 = mkSubst iss0- iss0 = mkInScopeSet (localFVsOfTerms [e] `unionUniqSet` tyFVsOfTypes [ty])+ iss0 = mkInScopeSet (freeVarsOf e `unionUniqSet` freeVarsOf ty) instantiate tcm pVal@(PrimVal (PrimInfo{primType}) tys []) ty m | isUndefinedPrimVal pVal- = setTerm (undefinedTm (piResultTys tcm primType (tys ++ [ty]))) m+ = setTerm (TyApp (Prim NP.undefined) (piResultTys tcm primType (tys ++ [ty]))) m instantiate _ p _ _ = error $ "Evaluator.instantiate: Not a tylambda: " ++ show p @@ -369,7 +372,7 @@ ba1 = BA.ByteArray ba0 in Just (ByteArrayLiteral ba1) _ -> Nothing- = let inScope = localFVsOfTerms [altE]+ = let inScope = freeVarsOf altE subst0 = mkSubst (mkInScopeSet inScope) subst1 = extendIdSubst subst0 x (Literal patE) in substTm "Evaluator.scrutinise" subst1 altE@@ -386,7 +389,7 @@ ba1 = BA.ByteArray ba0 in Just (ByteArrayLiteral ba1) _ -> Nothing- = let inScope = localFVsOfTerms [altE]+ = let inScope = freeVarsOf altE subst0 = mkSubst (mkInScopeSet inScope) subst1 = extendIdSubst subst0 x (Literal patE) in substTm "Evaluator.scrutinise" subst1 altE@@ -400,7 +403,7 @@ scrutinise v@(PrimVal p _ vs) altTy alts m | isUndefinedPrimVal v- = setTerm (undefinedTm altTy) m+ = setTerm (TyApp (Prim NP.undefined) altTy) m | any (\case {(LitPat {},_) -> True; _ -> False}) alts = case alts of@@ -436,7 +439,7 @@ tms = lefts args substTyMap = zip tvs (drop (length (dcUnivTyVars dc)) tys) substTmMap = zip xs tms- inScope = tyFVsOfTypes tys `unionVarSet` localFVsOfTerms (e:tms)+ inScope = freeVarsOf tys `unionVarSet` freeVarsOf (e:tms) subst = extendTvSubstList (extendIdSubstList subst0 substTmMap) substTyMap subst0 = mkSubst (mkInScopeSet inScope)
src-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -1,9 +1,10 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd,- 2017 , QBayLogic, Google Inc.+ 2017 , QBayLogic, Google Inc.,+ 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-}@@ -27,6 +28,7 @@ import Control.Monad.State.Strict (State, MonadState) import qualified Control.Monad.State.Strict as State import Control.Monad.Trans.Except (runExcept)+import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, wordToFloat) import Data.Bits import Data.Char (chr,ord) import qualified Data.Either as Either@@ -79,13 +81,14 @@ import Clash.Class.BitPack (pack,unpack) import Clash.Core.DataCon (DataCon (..)) import Clash.Core.Evaluator.Types+import Clash.Core.HasType (piResultTys, applyTypeToArgs) 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)+ (IsMultiPrim (..), Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps,+ PrimUnfolding(..)) import Clash.Core.Type (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp, splitFunForallTy, tyView)@@ -93,8 +96,7 @@ (TyConMap, TyConName, tyConDataCons) import Clash.Core.TysPrim import Clash.Core.Util- (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo,- undefinedTm, mkSelectorCase)+ (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase) import Clash.Core.Var (mkLocalId, mkTyVar) import Clash.Debug import Clash.GHC.GHC2Core (modNameM)@@ -105,6 +107,7 @@ (typeNatMul, typeNatSub, typeNatAdd, vecLastPrim, vecInitPrim, vecHeadPrim, vecTailPrim, mkVecCons, mkVecNil) +import qualified Clash.Normalize.Primitives as NP import Clash.Promoted.Nat.Unsafe (unsafeSNat) import qualified Clash.Sized.Internal.BitVector as BitVector import qualified Clash.Sized.Internal.Signed as Signed@@ -118,7 +121,7 @@ isUndefinedPrimVal :: Value -> Bool isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) =- primName `elem` ["Clash.Transformations.undefined"+ primName `elem` [ Text.pack (show 'NP.undefined) ,"Clash.XException.errorX" ,"Control.Exception.Base.absentError"] isUndefinedPrimVal _ = False@@ -128,9 +131,9 @@ ghcPrimUnwind tcm p tys vs v [] m | primName p `elem` [ "Clash.Sized.Internal.Index.fromInteger#" , "GHC.CString.unpackCString#"- , "Clash.Transformations.removedArg"+ , Text.pack (show 'NP.removedArg) , "GHC.Prim.MutableByteArray#"- , "Clash.Transformations.undefined"+ , Text.pack (show 'NP.undefined) ] -- The above primitives are actually values, and not operations. = ghcUnwind (PrimVal p tys (vs ++ [v])) m tcm@@ -157,7 +160,7 @@ | isUndefinedPrimVal v = let tyArgs = map Right tys tmArgs = map (Left . valToTerm) (vs ++ [v])- in Just $ flip setTerm m $ undefinedTm $+ in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs) | otherwise = ghcPrimStep tcm (forcePrims m) p tys (vs ++ [v]) m@@ -177,7 +180,7 @@ = if isUndefinedPrimVal v then let tyArgs = map Right tys tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ [Left e]- in Just $ flip setTerm m0 $ undefinedTm $+ in Just $ flip setTerm m0 $ TyApp (Prim NP.undefined) $ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs) else let (m1,i) = newLetBinding tcm m0 e@@ -187,7 +190,7 @@ | isUndefinedPrimVal v = let tyArgs = map Right tys tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ map Left (e:es)- in Just $ flip setTerm m $ undefinedTm $+ in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs) | otherwise = Just . setTerm e $ stackPush (PrimApply p tys (vs ++ [foldr TickValue v ts]) es) m@@ -310,17 +313,17 @@ "GHC.Prim.int2Float#" | [Lit (IntLiteral i)] <- args- -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)+ -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i "GHC.Prim.int2Double#" | [Lit (IntLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)+ -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i "GHC.Prim.word2Float#" | [Lit (WordLiteral i)] <- args- -> reduce . Literal . FloatLiteral . toRational $ (fromInteger i :: Float)+ -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i "GHC.Prim.word2Double#" | [Lit (WordLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)+ -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i "GHC.Prim.uncheckedIShiftL#" | [ Lit (IntLiteral i)@@ -561,13 +564,14 @@ -> reduce r "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args- -> let !(D# a) = fromRational i+ -> let !(D# a) = wordToDouble 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))))-+ -> let !(D# a) = wordToDouble d+ r = double2Float# a+ in reduce . Literal . FloatLiteral . floatToWord $ F# r "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args -> reduce r@@ -610,7 +614,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = lookupUniqMap tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i+ !(D# a) = wordToDouble i !(# p, q, r, s #) = decodeDouble_2Int# a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -623,7 +627,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = lookupUniqMap tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i+ !(D# a) = wordToDouble i !(# p, q #) = decodeDouble_Int64# a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -661,7 +665,7 @@ -> reduce r "GHC.Prim.float2Int#" | [i] <- floatLiterals' args- -> let !(F# a) = fromRational i+ -> let !(F# a) = wordToFloat i r = float2Int# a in reduce . Literal . IntLiteral . toInteger $ I# r @@ -692,7 +696,6 @@ "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@@ -704,7 +707,6 @@ -> 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@@ -716,9 +718,9 @@ #endif "GHC.Prim.float2Double#" | [i] <- floatLiterals' args- -> let !(F# a) = fromRational i+ -> let !(F# a) = wordToFloat i r = float2Double# a- in reduce . Literal . DoubleLiteral . toRational $ D# r+ in reduce . Literal . DoubleLiteral . doubleToWord $ D# r "GHC.Prim.newByteArray#"@@ -732,7 +734,7 @@ 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 (mkApps (Prim (PrimInfo "GHC.Prim.MutableByteArray#" mbaTy WorkNever SingleResult NoUnfolding)) [Left (Literal . IntLiteral $ toInteger p)]) ]) in Just . setTerm newE $ primInsert p lit mach@@ -900,7 +902,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = lookupUniqMap tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(F# a) = fromRational i+ !(F# a) = wordToFloat i !(# p, q #) = decodeFloat_Int# a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -991,7 +993,7 @@ -> if divisor == 0 then let iTy = snd (splitFunForallTy ty) in- reduce (undefinedTm iTy)+ reduce (TyApp (Prim NP.undefined) iTy) else reduce (Literal (IntLiteral (dividend `mod` divisor))) @@ -1039,7 +1041,7 @@ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = lookupUniqMap tupTcNm tcm [tupDc] = tyConDataCons tupTc- !(D# a) = fromRational i+ !(D# a) = wordToDouble i !(# b, c #) = decodeDoubleInteger a in reduce $ mkApps (Data tupDc) (map Right tyArgs ++@@ -1055,7 +1057,7 @@ , [i] <- integerLiterals' [iV] -> let !(I# k') = fromInteger j r = encodeDoubleInteger i k'- in reduce . Literal . DoubleLiteral . toRational $ D# r+ in reduce . Literal . DoubleLiteral . doubleToWord $ D# r #if MIN_VERSION_base(4,15,0) "GHC.Num.Integer.integerEncodeFloat#"@@ -1063,7 +1065,7 @@ , [i] <- integerLiterals' [iV] -> let !(I# k') = fromInteger j r = integerEncodeFloat# i k'- in reduce . Literal . FloatLiteral . toRational $ F# r+ in reduce . Literal . FloatLiteral . floatToWord $ F# r #endif #if MIN_VERSION_base(4,15,0)@@ -1570,9 +1572,6 @@ -- 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)))@@ -1596,13 +1595,6 @@ [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@@ -1632,13 +1624,6 @@ [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@@ -1677,9 +1662,9 @@ -> case fromInteger matDigs of matDigs' | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+ -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d))))) | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+ -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d))))) _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double" "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile@@ -1691,9 +1676,9 @@ -> case fromInteger matDigs of matDigs' | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+ -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d))))) | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+ -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d))))) _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double" #if MIN_VERSION_base(4,15,0)@@ -1773,7 +1758,7 @@ "GHC.Integer.Type.doubleFromInteger" #endif | [i] <- integerLiterals' args- -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))+ -> reduce (Literal (DoubleLiteral (doubleToWord (fromInteger i)))) "GHC.Base.eqString" | [PrimVal _ _ [Lit (StringLiteral s1)]@@ -1783,33 +1768,33 @@ | otherwise -> error (show args) - "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64+ "Clash.Class.BitPack.Internal.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)+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word64 -> BitVector 64) i) } - "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32+ "Clash.Class.BitPack.Internal.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)+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word32 -> BitVector 32) i) } - "Clash.Class.BitPack.unpackFloat#"+ "Clash.Class.BitPack.Internal.unpackFloat#" | [i] <- bitVectorLiterals' args- -> reduce (Literal (FloatLiteral (toRational $ (unpack :: BitVector 32 -> Float) (toBV i))))+ -> reduce . Literal . FloatLiteral $ unpack (toBV i :: BitVector 32) - "Clash.Class.BitPack.unpackDouble#"+ "Clash.Class.BitPack.Internal.unpackDouble#" | [i] <- bitVectorLiterals' args- -> reduce (Literal (DoubleLiteral (toRational $ (unpack :: BitVector 64 -> Double) (toBV i))))+ -> reduce . Literal . DoubleLiteral $ unpack (toBV i :: BitVector 64) -- expIndex# -- :: KnownNat m@@ -1944,6 +1929,12 @@ "Clash.Sized.Internal.BitVector.le##" | [(0,i),(0,j)] <- bitLiterals args -> reduce (boolToBoolLiteral tcm ty (i <= j)) +-- Enum+ "Clash.Sized.Internal.BitVector.toEnum##"+ | [i] <- intLiterals' args+ -> let Bit msk val = BitVector.toEnum## (fromInteger i)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))+ -- Bits "Clash.Sized.Internal.BitVector.and##" | [i,j] <- bitLiterals args@@ -2146,6 +2137,18 @@ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.le# ty tcm args) -> reduce val +-- Enum++ "Clash.Sized.Internal.BitVector.toEnum#"+ | let resTyInfo@(_,_,kn) = extractTySizeInfo tcm ty tys+ , Just val <- reifyNat kn (liftInteger2BitVector (BitVector.toEnum# . fromInteger) resTyInfo args)+ -> reduce val++ "Clash.Sized.Internal.BitVector.fromEnum#"+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Int (toInteger . BitVector.fromEnum#) args)+ -> reduce val+ -- Bounded "Clash.Sized.Internal.BitVector.minBound#" | Just (nTy,len) <- extractKnownNat tcm tys@@ -2318,6 +2321,16 @@ | Just (i,j) <- indexLiterals args -> reduce (boolToBoolLiteral tcm ty (i <= j)) +-- Enum+ "Clash.Sized.Internal.Index.toEnum#"+ | [i] <- intLiterals' args+ , Just (nTy, mb) <- extractKnownNat tcm tys+ -> reduce (mkIndexLit ty nTy mb i)++ "Clash.Sized.Internal.Index.fromEnum#"+ | [i] <- indexLiterals' args+ -> reduce (integerToIntLiteral i)+ -- Bounded "Clash.Sized.Internal.Index.maxBound#" | Just (nTy,mb) <- extractKnownNat tcm tys@@ -2424,6 +2437,16 @@ "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args -> reduce (boolToBoolLiteral tcm ty (i <= j)) +-- Enum+ "Clash.Sized.Internal.Signed.toEnum#"+ | [i] <- intLiterals' args+ , Just (litTy, mb) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty litTy mb i)++ "Clash.Sized.Internal.Signed.fromEnum#"+ | [i] <- signedLiterals' args+ -> reduce (integerToIntLiteral i)+ -- Bounded "Clash.Sized.Internal.Signed.minBound#" | Just (litTy,mb) <- extractKnownNat tcm tys@@ -2631,6 +2654,16 @@ "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args -> reduce (boolToBoolLiteral tcm ty (i <= j)) +-- Enum+ "Clash.Sized.Internal.Unsigned.toEnum#"+ | [i] <- intLiterals' args+ , Just (litTy, mb) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty litTy mb i)++ "Clash.Sized.Internal.Unsigned.fromEnum#"+ | [i] <- unsignedLiterals' args+ -> reduce (integerToIntLiteral i)+ -- Bounded "Clash.Sized.Internal.Unsigned.minBound#" | Just (nTy,len) <- extractKnownNat tcm tys@@ -3235,12 +3268,6 @@ _ -> 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@@ -3399,7 +3426,7 @@ , 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))+ mkApps (Prim (PrimInfo "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm) WorkNever SingleResult NoUnfolding)) [Right nTy ,Right nTy ,Right aTy@@ -3428,7 +3455,7 @@ ,Right (LitTy (NumTy (m'-1))) ,Right aTy ,Right bTy- ,Left (mkApps (Prim (PrimInfo "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm) WorkVariable SingleResult))+ ,Left (mkApps (Prim (PrimInfo "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm) WorkVariable SingleResult NoUnfolding)) [Right nTy ,Left (Literal (NaturalLiteral n')) ,Left (valToTerm n)@@ -3537,7 +3564,7 @@ n1mTy = LitTy (NumTy n1) n1m'ty = LitTy (NumTy (n1-1)) splitAtCall =- mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever SingleResult))+ mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever SingleResult NoUnfolding)) [Right mTy ,Right n1mTy ,Right aTy@@ -3898,7 +3925,7 @@ -> Term checkNaturalRange nTy natsAsInts f = if any (<0) natsAsInts then- undefinedTm nTy+ TyApp (Prim NP.undefined) nTy else f (map fromInteger natsAsInts) @@ -3921,7 +3948,7 @@ makeUndefinedIf wantToHandle tm = case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of Right b -> b- Left e -> trace (msg e) (undefinedTm resTy)+ Left e -> trace (msg e) (TyApp (Prim NP.undefined) resTy) where resTy = getResultTy tcm ty tys selectException e | wantToHandle e = Just e@@ -3954,18 +3981,18 @@ (s,i1) | even s -> i1 | otherwise -> i1 - mask -doubleLiterals' :: [Value] -> [Rational]+doubleLiterals' :: [Value] -> [Word64] doubleLiterals' = listOf doubleLiteral -doubleLiteral :: Value -> Maybe Rational+doubleLiteral :: Value -> Maybe Word64 doubleLiteral v = case v of Lit (DoubleLiteral i) -> Just i _ -> Nothing -floatLiterals' :: [Value] -> [Rational]+floatLiterals' :: [Value] -> [Word32] floatLiterals' = listOf floatLiteral -floatLiteral :: Value -> Maybe Rational+floatLiteral :: Value -> Maybe Word32 floatLiteral v = case v of Lit (FloatLiteral i) -> Just i _ -> Nothing@@ -4268,7 +4295,7 @@ , val < kn = Right (mkSizedLit indexConPrim rTy nTy kn val) | otherwise- = Left (undefinedTm (mkTyConApp indexTcNm [nTy]))+ = Left (TyApp (Prim NP.undefined) (mkTyConApp indexTcNm [nTy])) where TyConApp indexTcNm _ = tyView (snd (splitFunForallTy rTy)) @@ -4331,14 +4358,14 @@ bConPrim :: Type -> Term bConPrim (tyView -> TyConApp bTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever SingleResult)+ = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever SingleResult NoUnfolding) 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)+ = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding) where funTy = foldr1 mkFunTy [naturalPrimTy,naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]] nName = mkUnsafeSystemName "n" 0@@ -4348,7 +4375,7 @@ indexConPrim :: Type -> Term indexConPrim (tyView -> TyConApp indexTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding) where funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]] nName = mkUnsafeSystemName "n" 0@@ -4358,7 +4385,7 @@ signedConPrim :: Type -> Term signedConPrim (tyView -> TyConApp signedTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ = Prim (PrimInfo "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding) where funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]] nName = mkUnsafeSystemName "n" 0@@ -4368,7 +4395,7 @@ unsignedConPrim :: Type -> Term unsignedConPrim (tyView -> TyConApp unsignedTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult)+ = Prim (PrimInfo "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding) where funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]] nName = mkUnsafeSystemName "n" 0@@ -4424,6 +4451,32 @@ in Just $ boolToBoolLiteral tcm ty val | otherwise = Nothing +liftInteger2BitVector+ :: KnownNat n+ => (Integer -> BitVector n)+ -> (Type, Type, Integer)+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftInteger2BitVector f resTyInfo args _p+ | [i] <- intLiterals' args+ = let BV msk val = f i+ in Just (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))++ | otherwise+ = Nothing++liftBitVector2Int+ :: KnownNat n+ => (BitVector n -> Integer)+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2Int f args _p+ | [i] <- bitVectorLiterals' args+ = let val = f (toBV i)+ in Just $ integerToIntLiteral val+ | otherwise+ = Nothing+ liftSized2 :: (KnownNat n, Integral (sized n)) => ([Value] -> [Integer]) -- ^ literal argument extraction function@@ -4487,23 +4540,23 @@ liftDD f args = case doubleLiterals' args of [i] -> Just $ runDD f i _ -> Nothing-runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term+runDDI :: (Double# -> Double# -> Int#) -> Word64 -> Word64 -> Term runDDI f i j- = let !(D# a) = fromRational i- !(D# b) = fromRational j+ = let !(D# a) = wordToDouble i+ !(D# b) = wordToDouble j r = f a b in Literal . IntLiteral . toInteger $ I# r-runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term+runDDD :: (Double# -> Double# -> Double#) -> Word64 -> Word64 -> Term runDDD f i j- = let !(D# a) = fromRational i- !(D# b) = fromRational j+ = let !(D# a) = wordToDouble i+ !(D# b) = wordToDouble j r = f a b- in Literal . DoubleLiteral . toRational $ D# r-runDD :: (Double# -> Double#) -> Rational -> Term+ in Literal . DoubleLiteral . doubleToWord $ D# r+runDD :: (Double# -> Double#) -> Word64 -> Term runDD f i- = let !(D# a) = fromRational i+ = let !(D# a) = wordToDouble i r = f a- in Literal . DoubleLiteral . toRational $ D# r+ in Literal . DoubleLiteral . doubleToWord $ D# r liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term liftFFI f args = case floatLiterals' args of@@ -4517,23 +4570,23 @@ liftFF f args = case floatLiterals' args of [i] -> Just $ runFF f i _ -> Nothing-runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term+runFFI :: (Float# -> Float# -> Int#) -> Word32 -> Word32 -> Term runFFI f i j- = let !(F# a) = fromRational i- !(F# b) = fromRational j+ = let !(F# a) = wordToFloat i+ !(F# b) = wordToFloat j r = f a b in Literal . IntLiteral . toInteger $ I# r-runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term+runFFF :: (Float# -> Float# -> Float#) -> Word32 -> Word32 -> Term runFFF f i j- = let !(F# a) = fromRational i- !(F# b) = fromRational j+ = let !(F# a) = wordToFloat i+ !(F# b) = wordToFloat j r = f a b- in Literal . FloatLiteral . toRational $ F# r-runFF :: (Float# -> Float#) -> Rational -> Term+ in Literal . FloatLiteral . floatToWord $ F# r+runFF :: (Float# -> Float#) -> Word32 -> Term runFF f i- = let !(F# a) = fromRational i+ = let !(F# a) = wordToFloat i r = f a- in Literal . FloatLiteral . toRational $ F# r+ in Literal . FloatLiteral . floatToWord $ F# r splitAtPrim :: TyConName@@ -4542,7 +4595,7 @@ -- ^ Vec TyCon name -> Term splitAtPrim snatTcNm vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm) WorkNever SingleResult)+ Prim (PrimInfo "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm) WorkNever SingleResult NoUnfolding) splitAtTy :: TyConName@@ -4609,7 +4662,7 @@ -- ^ Vec TyCon name -> Term vecAppendPrim vecNm =- Prim (PrimInfo "Clash.Sized.Vector.++" (vecAppendTy vecNm) WorkNever SingleResult)+ Prim (PrimInfo "Clash.Sized.Vector.++" (vecAppendTy vecNm) WorkNever SingleResult NoUnfolding) vecAppendTy :: TyConName@@ -4642,7 +4695,7 @@ -- ^ Vec TyCon name -> Term vecZipWithPrim vecNm =- Prim (PrimInfo "Clash.Sized.Vector.zipWith" (vecZipWithTy vecNm) WorkNever SingleResult)+ Prim (PrimInfo "Clash.Sized.Vector.zipWith" (vecZipWithTy vecNm) WorkNever SingleResult NoUnfolding) vecZipWithTy :: TyConName@@ -4714,7 +4767,7 @@ -- ^ BitVector TyCon Name -> Term bvAppendPrim bvTcNm =- Prim (PrimInfo "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm) WorkNever SingleResult)+ Prim (PrimInfo "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm) WorkNever SingleResult NoUnfolding) bvAppendTy :: TyConName@@ -4739,7 +4792,7 @@ -- ^ BitVector TyCon Name -> Term bvSplitPrim bvTcNm =- Prim (PrimInfo "Clash.Sized.Internal.BitVector.split#" (bvSplitTy bvTcNm) WorkNever SingleResult)+ Prim (PrimInfo "Clash.Sized.Internal.BitVector.split#" (bvSplitTy bvTcNm) WorkNever SingleResult NoUnfolding) bvSplitTy :: TyConName
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -2,8 +2,9 @@ Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2818, Google Inc.+ 2021, QBayLogic B.V., License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-}@@ -31,18 +32,17 @@ where -- External Modules-import Control.Lens ((^.), (%~), (&), (%=), (.~), view)+import Control.Lens ((^.), (%~), (&), (%=), (.~), view, makeLenses) import Control.Monad.RWS.Strict (RWS) import qualified Control.Monad.RWS.Strict as RWS+import Data.Bifunctor (second)+import Data.Binary.IEEE754 (doubleToWord, floatToWord) import qualified Data.ByteString.Char8 as Char8 import Data.Char (isDigit) import Data.Hashable (Hashable (..)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes,fromMaybe,listToMaybe)-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif import Data.Text (Text, pack) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8)@@ -60,7 +60,8 @@ collectArgs, rhssOfAlts, unfoldingTemplate) import GHC.Core.DataCon (DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag,- dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel)+ dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel,+ HsImplBang(..), dataConImplBangs) import GHC.Driver.Session (unsafeGlobalDynFlags) import GHC.Core.FamInstEnv (FamInst (..), FamInstEnvs, familyInstances, normaliseType, emptyFamInstEnvs)@@ -71,7 +72,7 @@ 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.Builtin.Names (integerTyConKey, naturalTyConKey) import GHC.Types.Name.Occurrence (occNameString) import GHC.Utils.Outputable (showPpr) import GHC.Data.Pair (Pair (..))@@ -80,7 +81,7 @@ (AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon, isFunTyCon, isNewTyCon, isPrimTyCon, isTupleTyCon, isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe, tyConArity,- tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon)+ tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon, isPromotedDataCon_maybe) import GHC.Core.Type (mkTvSubstPrs, substTy, coreView) import GHC.Core.TyCo.Rep (Coercion (..), TyLit (..), Type (..), scaledThing) import GHC.Types.Unique (Uniquable (..), Unique, getKey, hasKey)@@ -96,7 +97,7 @@ import CoreSyn (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..), collectArgs, rhssOfAlts, unfoldingTemplate)-import DataCon (DataCon,+import DataCon (DataCon, HsImplBang(..), #if MIN_VERSION_ghc(8,8,0) dataConExTyCoVars, #else@@ -105,7 +106,7 @@ dataConName, dataConRepArgTys, dataConTag, dataConTyCon, dataConUnivTyVars, dataConWorkId,- dataConFieldLabels, flLabel)+ dataConFieldLabels, flLabel, dataConImplBangs) import DynFlags (unsafeGlobalDynFlags) import FamInstEnv (FamInst (..), FamInstEnvs, familyInstances, normaliseType, emptyFamInstEnvs)@@ -118,21 +119,18 @@ import Id (isDataConId_maybe) import IdInfo (IdDetails (..), unfoldingInfo)-import Literal (Literal (..))-#if MIN_VERSION_ghc(8,6,0)-import Literal (LitNumType (..))-#endif+import Literal (Literal (..), LitNumType (..)) import Module (moduleName, moduleNameString) import Name (Name, nameModule_maybe, nameOccName, nameUnique, getSrcSpan)-import PrelNames (tYPETyConKey, integerTyConKey, naturalTyConKey)+import PrelNames (integerTyConKey, naturalTyConKey) import OccName (occNameString) import Outputable (showPpr) import Pair (Pair (..)) import SrcLoc (SrcSpan (..), isGoodSrcSpan) import TyCon (AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon,- isFunTyCon, isNewTyCon,+ isFunTyCon, isNewTyCon, isPromotedDataCon_maybe, isPrimTyCon, isTupleTyCon, isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe,@@ -161,6 +159,7 @@ import qualified Clash.Core.Term as C import qualified Clash.Core.TyCon as C import qualified Clash.Core.Type as C+import qualified Clash.Core.Util as C (undefinedTy) import qualified Clash.Core.Var as C import Clash.Primitives.Types import qualified Clash.Unique as C@@ -198,9 +197,6 @@ instance Monoid SrcSpanRB where mempty = SrcSpanRB noSrcSpan-#if !MIN_VERSION_base(4,11,0)- mappend = (<>)-#endif type C2C = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState @@ -228,7 +224,7 @@ | isTupleTyCon tc = mkTupleTyCon | isAlgTyCon tc = mkAlgTyCon | isPrimTyCon tc = mkPrimTyCon- | tc `hasKey` tYPETyConKey = mkSuperKindTyCon+ | Just dc <- isPromotedDataCon_maybe tc = mkPromotedDataCon dc | otherwise = mkVoidTyCon where tcArity = tyConArity tc@@ -295,13 +291,20 @@ , C.tyConArity = tcArity } - mkSuperKindTyCon = do+ mkPromotedDataCon dc = do tcName <- coreToName tyConName tyConUnique qualifiedNameString tc- return C.SuperKindTyCon- { C.tyConUniq = C.nameUniq tcName- , C.tyConName = tcName- }+ tcKind <- coreToType (tyConKind tc)+ tcData <- coreToDataCon dc + return+ C.PromotedDataCon+ { C.tyConUniq = C.nameUniq tcName+ , C.tyConName = tcName+ , C.tyConKind = tcKind+ , C.tyConArity = tcArity+ , C.tyConData = tcData+ }+ mkVoidTyCon = do tcName <- coreToName tyConName tyConUnique qualifiedNameString tc tcKind <- coreToType (tyConKind tc)@@ -316,16 +319,8 @@ makeAlgTyConRhs :: AlgTyConRhs -> C2C (Maybe C.AlgTyConRhs) makeAlgTyConRhs algTcRhs = case algTcRhs of-#if MIN_VERSION_ghc(8,6,0) DataTyCon dcs _ _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-#else- DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-#endif-#if MIN_VERSION_ghc(8,6,0) SumTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-#else- SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-#endif #if MIN_VERSION_ghc(8,10,0) NewTyCon dc _ (rhsTvs,rhsEtad) _ _ ->@@ -386,7 +381,7 @@ go "GHC.Stack.withFrozenCallStack" args | length args == 3 = term (App (args!!2) (args!!1))- go "Clash.Class.BitPack.packXWith" args+ go "Clash.Class.BitPack.Internal.packXWith" args | [_nTy,_aTy,_kn,f] <- args = term f go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args@@ -454,12 +449,12 @@ (e1',sp) <- termSP (getSrcSpan x) e1 x' <- coreToIdSP sp x e2' <- term e2- return (C.Letrec [(x', e1')] e2')+ return (C.Let (C.NonRec x' e1') e2') term' (Let (Rec xes) e) = do xes' <- mapM go xes e' <- term e- return (C.Letrec xes' e')+ return (C.Let (C.Rec xes') e') where go (x,b) = do (b',sp) <- termSP (getSrcSpan x) b@@ -467,7 +462,7 @@ return (x',b') term' (Case _ _ ty []) =- C.TyApp (C.Prim (C.PrimInfo (pack "EmptyCase") C.undefinedTy C.WorkNever C.SingleResult))+ C.TyApp (C.Prim (C.PrimInfo (pack "EmptyCase") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding)) <$> coreToType ty term' (Case e b ty alts) = do let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (== b))@@ -480,7 +475,7 @@ if usesBndr then do ct <- caseTerm (C.Var b')- return (C.Letrec [(b', e')] ct)+ return (C.Let (C.NonRec b' e') ct) else caseTerm e' term' (Cast e co) = do@@ -500,10 +495,10 @@ #endif term' (Tick _ e) = term e term' (Type t) =- C.TyApp (C.Prim (C.PrimInfo (pack "_TY_") C.undefinedTy C.WorkNever C.SingleResult))+ C.TyApp (C.Prim (C.PrimInfo (pack "_TY_") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding)) <$> coreToType t term' (Coercion co) =- C.TyApp (C.Prim (C.PrimInfo (pack "_CO_") C.undefinedTy C.WorkNever C.SingleResult))+ C.TyApp (C.Prim (C.PrimInfo (pack "_CO_") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding)) <$> coreToType (coercionType co) @@ -528,7 +523,7 @@ 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)+ return $ C.Prim (C.PrimInfo xNameS xType (maybe C.WorkVariable workInfo p) C.SingleResult C.NoUnfolding) Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc)) then let xInfo = idInfo x unfolding = unfoldingInfo xInfo@@ -555,7 +550,7 @@ | f == "GHC.Magic.noinline" -> return (idTerm xType) | f == "GHC.Magic.lazy" -> return (idTerm xType) | f == "GHC.Magic.runRW#" -> return (runRWTerm xType)- | f == "Clash.Class.BitPack.packXWith" -> return (packXWithTerm xType)+ | f == "Clash.Class.BitPack.Internal.packXWith" -> return (packXWithTerm xType) | f == "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> return (checkUnpackUndefTerm xType) | f == "Clash.Magic.prefixName" -> return (nameModTerm C.PrefixName xType)@@ -565,18 +560,30 @@ -> return (nameModTerm C.SetName xType) | 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 C.SingleResult)- Just (Just (BlackBoxHaskell {workInfo = wi})) ->- return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult)+ | x `elem` unlocs+ -> return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding))+ | otherwise+ -> do bndr <- coreToId x+ return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult (C.Unfolding bndr)))+ Just (Just (BlackBox {workInfo = wi}))+ | x `elem` unlocs+ -> return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding)+ | otherwise+ -> do bndr <- coreToId x+ return (C.Prim (C.PrimInfo xNameS xType wi C.SingleResult (C.Unfolding bndr)))+ Just (Just (BlackBoxHaskell {workInfo = wi}))+ | x `elem` unlocs+ -> return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult C.NoUnfolding)+ | otherwise+ -> do bndr <- coreToId x+ return $ C.Prim (C.PrimInfo xNameS xType wi C.SingleResult (C.Unfolding bndr)) 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 C.SingleResult)+ return $ C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult C.NoUnfolding) Nothing | x `elem` unlocs- -> return (C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult))+ -> return (C.Prim (C.PrimInfo xNameS xType C.WorkVariable C.SingleResult C.NoUnfolding)) | otherwise -> C.Var <$> coreToId x @@ -603,7 +610,6 @@ MachStr fs -> C.StringLiteral (Char8.unpack fs) 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@@ -615,21 +621,14 @@ LitNumInt64 -> C.IntLiteral i LitNumWord -> C.WordLiteral i LitNumWord64 -> C.WordLiteral i-#else- MachInt i -> C.IntLiteral i- MachInt64 i -> C.IntLiteral i- MachWord i -> C.WordLiteral i- MachWord64 i -> C.WordLiteral i- LitInteger i _ -> C.IntegerLiteral i-#endif #if MIN_VERSION_ghc(8,8,0)- LitFloat r -> C.FloatLiteral r- LitDouble r -> C.DoubleLiteral r+ LitFloat r -> C.FloatLiteral . floatToWord $ fromRational r+ LitDouble r -> C.DoubleLiteral . doubleToWord $ fromRational r LitNullAddr -> C.StringLiteral [] LitLabel fs _ _ -> C.StringLiteral (unpackFS fs) #else- MachFloat r -> C.FloatLiteral r- MachDouble r -> C.DoubleLiteral r+ MachFloat r -> C.FloatLiteral . floatToWord $ fromRational r+ MachDouble r -> C.DoubleLiteral . doubleToWord $ fromRational r MachNullAddr -> C.StringLiteral [] MachLabel fs _ _ -> C.StringLiteral (unpackFS fs) #endif@@ -713,11 +712,7 @@ tcs <- catMaybes <$> mapM hasPrimCo coers return (listToMaybe tcs) -#if MIN_VERSION_ghc(8,6,0) hasPrimCo (NthCo _ _ co) = hasPrimCo co-#else-hasPrimCo (NthCo _ co) = hasPrimCo co-#endif hasPrimCo (LRCo _ co) = hasPrimCo co hasPrimCo (InstCo co _) = hasPrimCo co hasPrimCo (SubCo co) = hasPrimCo co@@ -741,6 +736,7 @@ #else let decLabel = decodeUtf8 . fastStringToByteString . flLabel #endif+ let repBangs = fmap hsImplBangToBool (dataConImplBangs dc) let fLabels = map decLabel (dataConFieldLabels dc) nm <- coreToName dataConName getUnique qualifiedNameString dc@@ -756,11 +752,17 @@ , C.dcTag = dataConTag dc , C.dcType = dcTy , C.dcArgTys = repTys+ , C.dcArgStrict = repBangs , C.dcUnivTyVars = uTvs , C.dcExtTyVars = eTvs , C.dcFieldLabels = fLabels } +hsImplBangToBool :: HsImplBang -> C.DcStrictness+hsImplBangToBool HsLazy = C.Lazy+hsImplBangToBool HsStrict = C.Strict+hsImplBangToBool HsUnpack{} = C.Strict+ typeConstructorToString :: TyCon -> C2C String@@ -772,8 +774,12 @@ -- | Flatten a list type structure to a list of types. listTypeToListOfTypes :: Type -> [Type]+-- TyConApp ': [kind, head, tail] listTypeToListOfTypes (TyConApp _ [_, a, as]) = a : listTypeToListOfTypes as-listTypeToListOfTypes _ = []+listTypeToListOfTypes ty =+ case coreView ty of+ Nothing -> []+ Just ty' -> listTypeToListOfTypes ty' -- | Try to determine boolean value by looking at constructor name of type. boolTypeToBool :: Type -> C2C Bool@@ -803,7 +809,7 @@ coreToAttr :: Type -> C2C C.Attr'-coreToAttr (TyConApp ty args) = do+coreToAttr t@(TyConApp ty args) = do let key = args !! 0 let value = args !! 1 name' <- typeConstructorToString ty@@ -821,8 +827,10 @@ "Clash.Annotations.SynthesisAttributes.Attr" -> return $ C.Attr' (tyLitToString key1) _ ->- error $ unwords [ "Expected StringAttr, IntegerAttr, BoolAttr or Attr"- , "constructor, got:" ++ name' ]+ case coreView t of+ Just t' -> coreToAttr t'+ Nothing -> error $ unwords [ "Expected StringAttr, IntegerAttr, BoolAttr or Attr"+ , "constructor, got:" ++ name' ] coreToAttr t = error $ unwords [ "Expected type constructor (TyConApp), but got:"@@ -846,7 +854,8 @@ let result | name' == "GHC.Types.[]" && name'' == _ATTR_NAME = -- List of attributes- sequence $ map coreToAttr (listTypeToListOfTypes attributes)+ traverse coreToAttr (listTypeToListOfTypes attributes)+ | name' == "GHC.Types.[]" = -- List, but unknown types error $ $(curLoc) ++ unwords [ "Annotate expects an"@@ -1324,8 +1333,8 @@ C.TyLam rTV ( C.TyLam oTV ( C.Lam fId (- (C.App (C.Var fId) (C.Prim (C.PrimInfo rwNm rwTy C.WorkNever C.SingleResult))))))- where+ (C.App (C.Var fId) (C.Prim (C.PrimInfo rwNm rwTy C.WorkNever C.SingleResult C.NoUnfolding))))))+ where (C.FunTy fTy _) = C.tyView funTy (C.FunTy rwTy _) = C.tyView fTy fName = C.mkUnsafeSystemName "f" 0
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -1,14 +1,16 @@ {-| Copyright : (C) 2013-2016, University of Twente,- 2017, QBayLogic, Google Inc.+ 2017, QBayLogic, Google Inc.,+ 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} module Clash.GHC.GenerateBindings (generateBindings)@@ -42,7 +44,6 @@ 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.Settings.Constants as GHC import qualified GHC.Types.Var as GHC import qualified GHC.Types.SrcLoc as GHC@@ -59,14 +60,12 @@ import qualified TyCon as GHC import qualified Type as GHC import qualified TysWiredIn as GHC-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.BitRepresentation.Internal (buildCustomReprs) import Clash.Annotations.Primitive (HDL, extractPrim)-import Clash.Signal.Internal import Clash.Core.Subst (extendGblSubstList, mkSubst, substTm) import Clash.Core.Term (Term (..), mkLams, mkTyLams)@@ -80,7 +79,7 @@ ,mkVarEnv, unionVarEnv, elemVarSet, mkVarSet) import Clash.Debug (traceIf) import Clash.Driver (compilePrimitive)-import Clash.Driver.Types (BindingMap, Binding(..), IsPrim(..))+import Clash.Driver.Types (BindingMap, Binding(..), IsPrim(..), ClashEnv(..), ClashDesign(..), ClashOpts(..)) import Clash.GHC.GHC2Core (C2C, GHC2CoreState, GHC2CoreEnv (..), tyConMap, coreToId, coreToName, coreToTerm, makeAllTyCons, qualifiedNameString, emptyGHC2CoreState, srcSpan)@@ -93,6 +92,7 @@ import Clash.Unique (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet) import Clash.Util (reportTimeDiff)+import qualified Clash.Util.Interpolate as I -- | Safe indexing, returns a 'Nothing' if the index does not exist indexMaybe :: [a] -> Int -> Maybe a@@ -101,12 +101,11 @@ indexMaybe (_:xs) n = indexMaybe xs (n-1) generateBindings- :: GHC.Ghc ()+ :: ClashOpts+ -> 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 -> [FilePath]@@ -117,15 +116,8 @@ -- ^ HDL target -> String -> Maybe GHC.DynFlags- -> IO ( BindingMap- , TyConMap- , IntMap TyConName- , [TopEntityT]- , CompiledPrimMap -- The primitives found in '.' and 'primDir'- , [DataRepr']- , HashMap.HashMap Text.Text VDomainConfiguration- )-generateBindings startAction useColor primDirs importDirs dbs hdl modName dflagsM = do+ -> IO (ClashEnv, ClashDesign)+generateBindings opts startAction primDirs importDirs dbs hdl modName dflagsM = do ( bindings , clsOps , unlocatable@@ -134,10 +126,10 @@ , partitionEithers -> (unresolvedPrims, pFP) , customBitRepresentations , primGuards- , domainConfs ) <- loadModules startAction useColor hdl modName dflagsM importDirs+ , domainConfs ) <- loadModules startAction (opt_color opts) hdl modName dflagsM importDirs+ startTime <- Clock.getCurrentTime primMapR <- generatePrimMap unresolvedPrims primGuards (concat [pFP, primDirs, importDirs]) tdir <- maybe ghcLibDir (pure . GHC.topDir) dflagsM- startTime <- Clock.getCurrentTime primMapC <- sequence $ HashMap.map (sequence . fmap (compilePrimitive importDirs dbs tdir))@@ -152,7 +144,9 @@ inScope0 = mkInScopeSet (uniqMapToUniqSet ((mapUniqMap (coerce . bindingId) bindingsMap) `unionUniqMap` (mapUniqMap (coerce . bindingId) clsMap)))- clsMap = mapUniqMap (\(v,i) -> (Binding v GHC.noSrcSpan GHC.Inline IsFun (mkClassSelector inScope0 allTcCache (varType v) i))) clsVMap+ -- Recursion info is always False for class+ -- selectors, no need to check free vars.+ clsMap = mapUniqMap (\(v,i) -> (Binding v GHC.noSrcSpan GHC.Inline IsFun (mkClassSelector inScope0 allTcCache (varType v) i) False)) clsVMap allBindings = bindingsMap `unionVarEnv` clsMap topEntities' = (\m -> fst (RWS.evalRWS m (GHC2CoreEnv GHC.noSrcSpan fiEnvs) tcMap')) $@@ -163,7 +157,10 @@ map (\(topEnt, annM, isTb) -> case lookupUniqMap topEnt allBindings of Just b -> TopEntityT (bindingId b) annM isTb- Nothing -> error "This shouldn't happen"+ Nothing -> GHC.pgmError [I.i|+ No top entity called '#{topEnt}' found. Make sure you are+ compiling with the '-fexpose-all-unfoldings' flag.+ |] ) topEntities' -- Parsing / compiling primitives: prepTime <- startTime `deepseq` primMapC `seq` Clock.getCurrentTime@@ -172,14 +169,20 @@ let allBindings' = setNoInlineTopEntities allBindings topEntities'' - return ( allBindings'- , allTcCache- , tupTcCache- , topEntities''- , primMapC- , customBitRepresentations- , domainConfs- )+ return+ ( ClashEnv+ { envOpts = opts+ , envTyConMap = allTcCache+ , envTupleTyCons = tupTcCache+ , envPrimitives = primMapC+ , envCustomReprs = buildCustomReprs customBitRepresentations+ }+ , ClashDesign+ { designEntities = topEntities''+ , designDomains = domainConfs+ , designBindings = allBindings'+ }+ ) setNoInlineTopEntities :: BindingMap@@ -220,7 +223,7 @@ nm <- qualifiedNameString (GHC.varName v) let pr = if HashMap.member nm primMap then IsPrim else IsFun checkPrimitive primMap v- return [(v', (Binding v' sp inl pr tm))]+ return [(v', (Binding v' sp inl pr tm False))] GHC.Rec bs -> do tms <- mapM (\(v,e) -> do let sp = GHC.getSrcSpan v@@ -230,10 +233,10 @@ nm <- qualifiedNameString (GHC.varName v) let pr = if HashMap.member nm primMap then IsPrim else IsFun checkPrimitive primMap v- return (Binding v' sp inl pr tm)+ return (Binding v' sp inl pr tm True) ) bs case tms of- [Binding v sp inl pr tm] -> return [(v, Binding v sp inl pr tm)]+ [Binding v sp inl pr tm r] -> return [(v, Binding v sp inl pr tm r)] -- Rewrite the bindings to avoid triggering the recursion check. -- See NOTE [bindings in recursive groups]@@ -241,7 +244,7 @@ vsV = map Var vsL subst = extendGblSubstList (mkSubst emptyInScopeSet) (zip vsL vsV) lbs = zipWith (\b vL -> (vL,substTm "mkBindings" subst (bindingTerm b))) tms vsL- tms1 = zipWith (\b (i, _) -> (bindingId b, b { bindingTerm = Letrec lbs (Var i) })) tms lbs+ tms1 = zipWith (\b (i, _) -> (bindingId b, b { bindingTerm = Letrec lbs (Var i), bindingRecursive = False })) tms lbs in return tms1 ) bindings clsOpList <- mapM (\(v,i) -> do
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -1,34 +1,47 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd+ 2022, QBayLogic B.V. License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} module Clash.GHC.LoadInterfaceFiles ( loadExternalExprs , loadExternalBinders , getUnresolvedPrimitives , LoadedBinders(..)- , mergeLoadedBinders- , emptyLb ) where -- External Modules import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad (forM_, join)+import Control.Monad.State.Strict+ (StateT, gets, MonadState (get), MonadTrans (lift), execStateT)+import Control.Monad.Trans.State.Strict (modify)+import Control.Monad.Extra (unlessM) import qualified Data.ByteString.Lazy.UTF8 as BLU import qualified Data.ByteString.Lazy as BL+import qualified Data.Sequence as Seq+import Data.Sequence (Seq) import Data.Either (partitionEithers)-import Data.List (elemIndex, foldl')+import Data.Foldable (foldl')+import Data.List (elemIndex) import qualified Data.Text as Text import Data.Maybe (isNothing, mapMaybe, catMaybes)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set import Data.Word (Word8) -- GHC API@@ -58,7 +71,6 @@ 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@@ -85,7 +97,6 @@ import qualified TcRnMonad import qualified TcRnTypes import qualified UniqFM-import qualified UniqSet import qualified Var #endif @@ -96,56 +107,135 @@ import Clash.Annotations.BitRepresentation (DataReprAnn) import Clash.Debug (traceIf) import Clash.Primitives.Types (UnresolvedPrimitive, name)-import Clash.Primitives.Util (decodeOrErr)+import Clash.Primitives.Util (decodeOrErrJson, decodeOrErrYaml) 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- { lbBinders :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]+ { lbBinders :: !(Map CoreSyn.CoreBndr CoreSyn.CoreExpr) -- ^ Binder + expression it's binding- , lbClassOps :: [(CoreSyn.CoreBndr, Int)]+ , lbClassOps :: !(Map CoreSyn.CoreBndr Int) -- ^ Type class dict projection functions- , lbUnlocatable :: [CoreSyn.CoreBndr]+ , lbUnlocatable :: !(Set CoreSyn.CoreBndr) -- ^ Binders with missing unfoldings- , lbPrims :: [Either UnresolvedPrimitive FilePath]+ , lbPrims :: !(Seq (Either UnresolvedPrimitive FilePath)) -- ^ Primitives; either an primitive data structure or a path to a directory -- containing json files- , lbReprs :: [DataRepr']+ , lbReprs :: !(Seq DataRepr') -- ^ Custom data representations+ , lbCache :: !DeclCache+ -- ^ Loaded module cache } -mergeLoadedBinders :: [LoadedBinders] -> LoadedBinders-mergeLoadedBinders lbs =- LoadedBinders {- lbBinders=concat (map lbBinders lbs)- , lbClassOps=concat (map lbClassOps lbs)- , lbUnlocatable=concat (map lbUnlocatable lbs)- , lbPrims=concat (map lbPrims lbs)- , lbReprs=concat (map lbReprs lbs)- }+type LoadedBinderT m a = StateT LoadedBinders m a +-- | Stores modules with easy binder lookup+type DeclCache = Map GHC.Module (Maybe (Map GHC.Name IfaceSyn.IfaceDecl))+++-- | Collects free variables in an expression, and splits them into "normal"+-- free variables and class ops.+bndrsInExpr :: CoreSyn.CoreExpr -> ([CoreSyn.CoreBndr], [(CoreSyn.CoreBndr, Int)])+bndrsInExpr e = partitionEithers (map go freeVars)+ where+ freeVars = CoreFVs.exprSomeFreeVarsList isInteresting e+ isInteresting v = Var.isId v && isNothing (Id.isDataConId_maybe v)++ go :: Var.Var -> Either Var.Id (CoreSyn.CoreBndr, Int)+ go v = case Id.isClassOpId_maybe v of+ Just cls -> Right (v, goClsOp v cls)+ Nothing -> Left v++ goClsOp :: Var.Var -> GHC.Class -> 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 -> n++-- | Add a binder to the appropriate fields of 'LoadedBinders', and recursively+-- load binders found in the optionally supplied expression.+addBndrM ::+ GHC.GhcMonad m =>+ HDL ->+ CoreSyn.CoreBndr ->+ Maybe CoreSyn.CoreExpr ->+ LoadedBinderT m ()+addBndrM hdl bndr exprM =+ case exprM of+ Nothing ->+ modify $ \lb@LoadedBinders{..} ->+ lb{lbUnlocatable=Set.insert bndr lbUnlocatable}+ Just expr -> do+ -- Add current expression and its class ops+ let (fvs, clsOps) = bndrsInExpr expr+ modify $ \lb@LoadedBinders{..} ->+ lb { lbBinders=Map.insert bndr expr lbBinders+ , lbClassOps=mapInsertAll lbClassOps clsOps }++ -- Load all free variables - if not yet loaded+ forM_ fvs $ \v ->+ unlessM (isLoadedBinderM v) (loadExprFromIface hdl v)+ where+ -- Insert a list of keys and values into a 'Map'+ mapInsertAll :: Ord k => Map k a -> [(k, a)] -> Map k a+ mapInsertAll = foldl' (\m (k, v) -> Map.insert k v m)+++isLoadedBinderM :: Monad m => CoreSyn.CoreBndr -> LoadedBinderT m Bool+isLoadedBinderM bndr = gets $ \LoadedBinders{..} ->+ Map.member bndr lbBinders+ || Map.member bndr lbClassOps+ || Set.member bndr lbUnlocatable+ emptyLb :: LoadedBinders-emptyLb = LoadedBinders [] [] [] [] []+emptyLb = LoadedBinders+ { lbBinders = mempty+ , lbClassOps = mempty+ , lbUnlocatable = mempty+ , lbPrims = mempty+ , lbReprs = mempty+ , lbCache = mempty+ } -collectLbBinders :: LoadedBinders -> [CoreSyn.CoreBndr]-collectLbBinders LoadedBinders{lbBinders, lbUnlocatable, lbClassOps} =- concat [map fst lbBinders, lbUnlocatable, map fst lbClassOps]+#if MIN_VERSION_ghc(9,0,0)+notBoot :: UnitTypes.IsBootInterface+notBoot = UnitTypes.NotBoot+#else+notBoot :: Bool+notBoot = False+#endif runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do+ let+ localEnv = TcRnTypes.IfLclEnv+ { TcRnTypes.if_mod = modName+ , TcRnTypes.if_boot = notBoot+ , TcRnTypes.if_loc = text "runIfl"+ , TcRnTypes.if_nsubst = Nothing+ , TcRnTypes.if_implicits_env = Nothing+ , TcRnTypes.if_tv_env = UniqFM.emptyUFM+ , TcRnTypes.if_id_env = UniqFM.emptyUFM+ }++ globalEnv = TcRnTypes.IfGblEnv+ { TcRnTypes.if_doc = text "Clash.runIfl"+ , TcRnTypes.if_rec_types = Nothing+ }+ hscEnv <- GHC.getSession- 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+ MonadUtils.liftIO $+ TcRnMonad.initTcRnIf 'r' hscEnv globalEnv localEnv action loadDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL GHC.TyThing loadDecl = TcIface.tcIfaceDecl False@@ -168,146 +258,135 @@ ] in traceIf True msg' (return Nothing) -loadExternalBinders- :: GHC.GhcMonad m- => HDL- -> [CoreSyn.CoreBndr]- -> m LoadedBinders-loadExternalBinders hdl bndrs = do- loaded <- mergeLoadedBinders <$> mapM (loadExprFromIface hdl) bndrs- fst <$>- loadExternalExprs'- hdl- loaded- (UniqSet.mkUniqSet (collectLbBinders loaded))- (map snd (lbBinders loaded))--loadExternalExprs- :: GHC.GhcMonad m- => HDL- -> UniqSet.UniqSet CoreSyn.CoreBndr- -> [CoreSyn.CoreBind]- -> m LoadedBinders-loadExternalExprs hdl = go emptyLb- where- go loaded _ [] =- return loaded- go loaded0 visited0 (CoreSyn.NonRec _ e:bs) = do- (loaded1, visited1) <- loadExternalExprs' hdl loaded0 visited0 [e]- go loaded1 visited1 bs- go loaded0 visited0 (CoreSyn.Rec bs:bs') = do- (loaded1, visited1) <- loadExternalExprs' hdl loaded0 visited0 (map snd bs)- go loaded1 visited1 bs'+-- | Given a list of top-level binders, recursively load all the binders,+-- primitives, and type classes it is using. (Exported function.)+loadExternalBinders :: GHC.GhcMonad m => HDL -> [CoreSyn.CoreBndr] -> m LoadedBinders+loadExternalBinders hdl bndrs =+ flip execStateT emptyLb $+ mapM_ (loadExprFromIface hdl) bndrs --- | Used by entry points: 'loadExternalExprs', 'loadExternalBinders'-loadExternalExprs'- :: GHC.GhcMonad m- => HDL- -> LoadedBinders- -> UniqSet.UniqSet CoreSyn.CoreBndr- -> [CoreSyn.CoreExpr]- -> m ( LoadedBinders, UniqSet.UniqSet CoreSyn.CoreBndr)-loadExternalExprs' _hdl loaded visited [] =- return (loaded, visited)-loadExternalExprs' hdl loaded0 visited0 (e:es) = do- let- isInteresting v =- Var.isId v- && not (v `UniqSet.elementOfUniqSet` visited0)- && isNothing (Id.isDataConId_maybe v)+-- Given a list of binds, recursively load all its binders, primitives, and+-- type classes it is using. (Exported function.)+loadExternalExprs :: GHC.GhcMonad m => HDL -> [CoreSyn.CoreBind] -> m LoadedBinders+loadExternalExprs hdl binds0 =+ flip execStateT initLb $+ mapM_ (\(b, e) -> addBndrM hdl b (Just e)) binds1+ where+ -- 'lbBinders' is preinitialized with all binders in given binds, as the given+ -- binders can't be loaded from precompiled modules+ initLb = emptyLb{lbBinders=Map.fromList binds1}+ binds1 = CoreSyn.flattenBinds binds0 - 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+-- | Try to fetch a IfaceDecl from a 'DeclCache'. If a module has not been loaded+-- before, load it using GHC. Additionally, add annotations mentioned in the+-- module to 'LoadedBinders'.+getIfaceDeclM ::+ forall m.+ GHC.GhcMonad m =>+ HDL ->+ -- | Binder to load+ CoreSyn.CoreBndr ->+ -- | Declaration, if found+ LoadedBinderT m (Maybe (GHC.Module, IfaceSyn.IfaceDecl))+getIfaceDeclM hdl bndr = do+ let modM = Name.nameModule_maybe bndrName+ join <$> mapM go modM+ where+ bndrName = Var.varName bndr - loaded1 <- mergeLoadedBinders <$> mapM (loadExprFromIface hdl) fvs2+ go :: GHC.Module -> LoadedBinderT m (Maybe (GHC.Module, IfaceSyn.IfaceDecl))+ go nameMod = do+ LoadedBinders{lbCache} <- get+ case Map.lookup nameMod lbCache of+ Nothing -> do+ -- Not loaded before+ ifaceM <- lift (runIfl nameMod (loadIface nameMod))+ case ifaceM of+ Just iface -> do+ -- Add binder : decl map to cache+ let+ decls = map snd (GHC.mi_decls iface)+ names = map IfaceSyn.ifName decls+ let declMap = Just (Map.fromList (zip names decls))+ modify (\lb -> lb{lbCache=Map.insert nameMod declMap lbCache}) - loadExternalExprs'- hdl- (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+ -- Load annotations and add them to state+ loadAnnotationsM hdl nameMod iface+ Nothing ->+ -- XXX: 'runIfl' should probably error hard if this happens?+ modify (\lb -> lb{lbCache=Map.insert nameMod Nothing lbCache}) - #{showPpr DynFlags.unsafeGlobalDynFlags v}+ -- Update cache and try again+ go nameMod - in class+ Just Nothing ->+ -- Loaded before, but couldn't find decl+ pure Nothing+ Just (Just declMap) ->+ -- Loaded before, decl found+ pure ((nameMod,) <$> Map.lookup bndrName declMap) - #{showPpr DynFlags.unsafeGlobalDynFlags c}- |]- Just n -> (v, n)+loadAnnotationsM ::+ GHC.GhcMonad m =>+ HDL ->+ GHC.Module ->+ GHC.ModIface ->+ StateT LoadedBinders m ()+loadAnnotationsM hdl modName iface = do+ anns <- lift (runIfl modName (TcIface.tcIfaceAnnotations (GHC.mi_anns iface)))+ primFPs <- loadPrimitiveAnnotations hdl anns+ let reprs = loadCustomReprAnnotations anns+ modify $ \lb@LoadedBinders{..} -> lb+ { lbPrims = lbPrims <> Seq.fromList primFPs+ , lbReprs = lbReprs <> Seq.fromList reprs+ } -loadExprFromIface- :: GHC.GhcMonad m- => HDL- -> CoreSyn.CoreBndr- -> m LoadedBinders+loadExprFromIface ::+ GHC.GhcMonad m =>+ HDL ->+ CoreSyn.CoreBndr ->+ LoadedBinderT m () loadExprFromIface hdl bndr = do- let moduleM = Name.nameModule_maybe $ Var.varName bndr- case moduleM of- Just nameMod -> runIfl nameMod $ do- ifaceM <- loadIface nameMod- case ifaceM of- Nothing ->- return (emptyLb{lbUnlocatable=[bndr]})- Just iface -> do- let decls = map snd (GHC.mi_decls iface)- let nameFun = GHC.getOccName $ Var.varName bndr- let declM = filter ((== nameFun) . Name.nameOccName . IfaceSyn.ifName) decls- anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface)- primFPs <- loadPrimitiveAnnotations hdl anns- let reprs = loadCustomReprAnnotations anns- lb = emptyLb{lbPrims=primFPs, lbReprs=reprs}- case declM of- [namedDecl] -> do- tyThing <- loadDecl namedDecl- case loadExprFromTyThing bndr tyThing of- Left bndr1 -> return (lb{lbBinders=[bndr1]})- Right unloc -> return (lb{lbUnlocatable=[unloc]})- _ -> return (lb{lbUnlocatable=[bndr]})- Nothing ->- return (emptyLb{lbUnlocatable=[bndr]})+ namedDeclM <- getIfaceDeclM hdl bndr+ case namedDeclM of+ Nothing -> addBndrM hdl bndr Nothing+ Just (nameMod, namedDecl) -> do+ tyThing <- lift (runIfl nameMod (loadDecl namedDecl))+ addBndrM hdl bndr (loadExprFromTyThing bndr tyThing) -loadCustomReprAnnotations- :: [Annotations.Annotation]- -> [DataRepr']+loadCustomReprAnnotations :: [Annotations.Annotation] -> [DataRepr'] loadCustomReprAnnotations anns =- catMaybes $ map go $ catMaybes $ zipWith filterNameless anns reprs- where- env = Annotations.mkAnnEnv anns- deserialize = GhcPlugins.deserializeWithData :: [Word8] -> DataReprAnn+ mapMaybe go $ catMaybes $ zipWith filterNameless anns reprs+ 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+ (mEnv, nEnv) = Annotations.deserializeAnns deserialize env+ reprs = ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv #else- reprs = UniqFM.eltsUFM (Annotations.deserializeAnns deserialize env)+ reprs = UniqFM.eltsUFM (Annotations.deserializeAnns deserialize env) #endif - filterNameless- :: Annotation- -> [DataReprAnn]- -> Maybe (Name.Name, [DataReprAnn])- filterNameless (Annotation ann_target _) reprs' =- (,reprs') <$> getAnnTargetName_maybe ann_target+ filterNameless :: Annotation -> [DataReprAnn] -> Maybe (Name.Name, [DataReprAnn])+ filterNameless (Annotation ann_target _) reprs' =+ (,reprs') <$> getAnnTargetName_maybe ann_target - go- :: (Name.Name, [DataReprAnn])- -> Maybe DataRepr'- go (_name, []) = Nothing- go (_name, [repr]) = Just $ dataReprAnnToDataRepr' repr- go (name, reprs') =- error $ $(curLoc) ++ "Multiple DataReprAnn annotations for same type: \n\n"- ++ (Outputable.showPpr DynFlags.unsafeGlobalDynFlags name)- ++ "\n\nReprs:\n\n"- ++ show reprs'+ go :: (Name.Name, [DataReprAnn]) -> Maybe DataRepr'+ go (_name, []) = Nothing+ go (_name, [repr]) = Just $ dataReprAnnToDataRepr' repr+ go (name, reprs') =+ error [I.i|+ Multiple DataReprAnn annotations for same type: + #{Outputable.showPpr DynFlags.unsafeGlobalDynFlags name}++ Reprs:++ #{reprs'}+ |]+ loadPrimitiveAnnotations :: MonadIO m => HDL@@ -327,20 +406,34 @@ :: MonadIO m => HDL -> (Annotations.CoreAnnTarget, Primitive)- -> m ([Either UnresolvedPrimitive FilePath])-getUnresolvedPrimitives hdl targetPrim =- case targetPrim of- (_, Primitive hdls fp) | hdl `elem` hdls -> pure [Right fp]+ -> m [Either UnresolvedPrimitive FilePath]+getUnresolvedPrimitives hdl (target, prim) | hdl `elem` primHdls prim =+ case prim of+ Primitive _ fp -> pure [Right fp] - (target, InlinePrimitive hdls contentOrFp) | hdl `elem` hdls ->+ InlineYamlPrimitive _ contentOrFp -> case target of -- Module annotation, can house many primitives Annotations.ModuleTarget _ ->- liftIO (decodeOrErr contentOrFp <$> BL.readFile contentOrFp)+ liftIO (decodeOrErrYaml contentOrFp <$> BL.readFile contentOrFp) Annotations.NamedTarget targetName0 -> let targetName1 = Text.unpack (qualifiedNameString' targetName0)- prim =- case decodeOrErr targetName1 (BLU.fromString contentOrFp) of+ primOrErr = decodeOrErrYaml targetName1 (BLU.fromString contentOrFp)+ primName = Text.unpack (name primOrErr) in++ if primName /= targetName1+ then inlineNameError targetName1 primName+ else pure [Left primOrErr]++ InlinePrimitive _ contentOrFp ->+ case target of+ -- Module annotation, can house many primitives+ Annotations.ModuleTarget _ ->+ liftIO (decodeOrErrJson contentOrFp <$> BL.readFile contentOrFp)+ Annotations.NamedTarget targetName0 ->+ let targetName1 = Text.unpack (qualifiedNameString' targetName0)+ primOrErr =+ case decodeOrErrJson targetName1 (BLU.fromString contentOrFp) of [] -> error $ "No annotations found for " ++ targetName1 ++ " even though it had an InlinePrimitive annotation." [p] -> p@@ -348,56 +441,46 @@ ++ "InlinePrimitive annotation for " ++ targetName1 ++ ". " ++ "Expected a single one." - primName = Text.unpack (name prim) in+ primName = Text.unpack (name primOrErr) in - if primName /= targetName1 then- error $ concat- [ "Function " ++ targetName1 ++ " was annotated with an inline "- , "primitive for " ++ primName ++ ". These names "- , "should be the same." ]- else- pure [Left prim]- _ ->- -- Only consider the HDL (Verilog/SystemVerilog/VHDL) annotation we're- -- currently targeting.- pure []+ if primName /= targetName1+ then inlineNameError targetName1 primName+ else pure [Left primOrErr]+ where+ inlineNameError targetName primName =+ error $ concat+ [ "Function " ++ targetName ++ " was annotated with an inline "+ , "primitive for " ++ primName ++ ". These names "+ , "should be the same." ] -loadExprFromTyThing- :: CoreSyn.CoreBndr- -> GHC.TyThing- -> Either- (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located Binder- CoreSyn.CoreBndr -- unlocatable Var+ primHdls = \case+ Primitive hdls _ -> hdls+ InlinePrimitive hdls _ -> hdls+ InlineYamlPrimitive hdls _ -> hdls++getUnresolvedPrimitives _ _ = return []++loadExprFromTyThing :: CoreSyn.CoreBndr -> GHC.TyThing -> Maybe CoreSyn.CoreExpr loadExprFromTyThing bndr tyThing = case tyThing of GHC.AnId _id | Var.isId _id -> let _idInfo = Var.idInfo _id unfolding = IdInfo.unfoldingInfo _idInfo in case unfolding of CoreSyn.CoreUnfolding {} ->- Left (bndr, CoreSyn.unfoldingTemplate unfolding)- (CoreSyn.DFunUnfolding dfbndrs dc es) ->- let dcApp = MkCore.mkCoreConApps dc es- dfExpr = MkCore.mkCoreLams dfbndrs dcApp- in Left (bndr,dfExpr)+ Just (CoreSyn.unfoldingTemplate unfolding)+ CoreSyn.DFunUnfolding dfbndrs dc es ->+ Just (MkCore.mkCoreLams dfbndrs (MkCore.mkCoreConApps dc es)) 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)- , MkCore.mkAbsentErrorApp-#else- , MkCore.mkRuntimeErrorApp- MkCore.aBSENT_ERROR_ID-#endif- (Var.varType _id)- ("no_unfolding " ++ showPpr unsafeGlobalDynFlags bndr)- )- _ -> Right bndr- _ -> Right bndr+ -> do+ let noUnfoldingErr = "no_unfolding " ++ showPpr unsafeGlobalDynFlags bndr+ Just (MkCore.mkAbsentErrorApp (Var.varType _id) noUnfoldingErr)+ _ -> Nothing+ _ -> Nothing #if MIN_VERSION_ghc(9,0,0) -- | Get the 'name' of an annotation target if it exists.
src-ghc/Clash/GHC/LoadModules.hs view
@@ -35,13 +35,10 @@ import Clash.Util (ClashException(..), pkgIdFromTypeable) import qualified Clash.Util.Interpolate as I 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@@ -50,6 +47,7 @@ import Data.Generics.Uniplate.DataOnly (transform) import Data.Data (Data) import Data.Functor ((<&>))+import Data.Foldable (toList) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Typeable (Typeable)@@ -60,6 +58,7 @@ import qualified Data.Text.Encoding as Text import qualified Data.Time.Clock as Clock import qualified Data.Set as Set+import qualified Data.Sequence as Seq import Debug.Trace import Language.Haskell.TH.Syntax (lift) import GHC.Natural (naturalFromInteger)@@ -119,9 +118,7 @@ import qualified CoreSyn import qualified DataCon import qualified Digraph-#if MIN_VERSION_ghc(8,6,0) import qualified DynamicLoading-#endif import DynFlags (GeneralFlag (..)) import qualified DynFlags import qualified Exception@@ -220,7 +217,7 @@ tyThings <- catMaybes <$> mapM GHC.lookupGlobalName (GHC.modInfoExports modInfo) let rootIds = [id_ | GHC.AnId id_ <- tyThings] loaded <- loadExternalBinders hdl rootIds- let allBinders = makeRecursiveGroups (lbBinders loaded)+ let allBinders = makeRecursiveGroups (Map.assocs (lbBinders loaded)) return (rootIds, FamInstEnv.emptyFamInstEnv, modName1, loaded, allBinders) setupGhc@@ -234,7 +231,6 @@ case dflagsM of Just df -> return df Nothing -> do-#if MIN_VERSION_ghc(8,6,0) -- Make sure we read the .ghc environment files df <- do df <- GHC.getSessionDynFlags@@ -246,9 +242,7 @@ _ <- GHC.setSessionDynFlags df {DynFlags.pkgDatabase = Nothing} #endif GHC.getSessionDynFlags-#else- df <- GHC.getSessionDynFlags-#endif+ let df1 = setWantedLanguageExtensions df ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise" ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"@@ -301,12 +295,10 @@ hscenv <- GHC.getSession dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3) _ <- GHC.setSessionDynFlags dflags4-#elif MIN_VERSION_ghc(8,6,0)+#else hscenv <- GHC.getSession dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3) _ <- GHC.setSessionDynFlags dflags4-#else- _ <- GHC.setSessionDynFlags dflags3 #endif return ()@@ -329,11 +321,7 @@ target <- GHC.guessTarget modName Nothing GHC.setTargets [target] modGraph <- GHC.depanal [] False-#if MIN_VERSION_ghc(8,4,1) let modGraph' = GHC.mapMG disableOptimizationsFlags modGraph-#else- let modGraph' = map disableOptimizationsFlags modGraph-#endif -- 'topSortModuleGraph' ensures that modGraph2, and hence tidiedMods -- are in topological order, i.e. the root module is last. modGraph2 = Digraph.flattenSCCs (GHC.topSortModuleGraph True modGraph' Nothing)@@ -365,11 +353,7 @@ tcMod' <- GHC.loadModule tcMod dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod' hsc_env <- GHC.getSession-#if MIN_VERSION_ghc(8,4,1) simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env [] dsMod-#else- simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod-#endif checkForInvalidPrelude simpl_guts (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts let pgm = HscTypes.cg_binds tidy_guts@@ -386,13 +370,13 @@ -- Because tidiedMods is in topological order, binders is also, and hence -- the binders belonging to the "root" module are the last binders let rootIds = map fst . CoreSyn.flattenBinds $ last binders- loaded0 <- loadExternalExprs hdl (UniqSet.mkUniqSet binderIds) (concat binders)+ loaded0 <- loadExternalExprs hdl (concat binders) -- Find local primitive annotations localPrims <- findPrimitiveAnnotations hdl binderIds- let loaded1 = loaded0{lbPrims=lbPrims loaded0 ++ localPrims}+ let loaded1 = loaded0{lbPrims=lbPrims loaded0 <> Seq.fromList localPrims} - let allBinders = concat binders ++ makeRecursiveGroups (lbBinders loaded0)+ let allBinders = concat binders ++ makeRecursiveGroups (Map.assocs (lbBinders loaded0)) pure (rootIds, modFamInstEnvs', rootModule, loaded1, allBinders) nameString :: Name.Name -> String@@ -434,6 +418,10 @@ -- '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+ setupTime <- MonadUtils.liftIO Clock.getCurrentTime+ let setupStartDiff = reportTimeDiff setupTime startTime+ MonadUtils.liftIO $ putStrLn $ "GHC: Setting up GHC took: " ++ setupStartDiff+ -- TODO: We currently load the transitive closure of _all_ bindings found -- TODO: in the top module. This is wasteful if one or more binders don't -- TODO: contribute to any top entities. This effect is worsened when using@@ -448,26 +436,18 @@ let allBinderIds = map fst (CoreSyn.flattenBinds allBinders) - modTime <- startTime `deepseq` length allBinderIds `seq` MonadUtils.liftIO Clock.getCurrentTime- let modStartDiff = reportTimeDiff modTime startTime- MonadUtils.liftIO $ putStrLn $ "GHC: Parsing and optimising modules took: " ++ modStartDiff-- extTime <- modTime `deepseq` length lbUnlocatable `deepseq` MonadUtils.liftIO Clock.getCurrentTime- let extModDiff = reportTimeDiff extTime modTime- MonadUtils.liftIO $ putStrLn $ "GHC: Loading external modules from interface files took: " ++ extModDiff+ modTime <- length allBinderIds `seq` MonadUtils.liftIO Clock.getCurrentTime+ let modStartDiff = reportTimeDiff modTime setupTime+ MonadUtils.liftIO $ putStrLn $ "GHC: Compiling and loading modules took: " ++ modStartDiff -- Get type family instances: accumulated by GhcMonad during -- 'loadExternalBinders' / 'loadExternalExprs' hscEnv <- GHC.getSession-#if MIN_VERSION_ghc(8,6,0) famInstEnvs <- do (msgs, m) <- TcRnMonad.liftIO $ TcRnMonad.initTcInteractive hscEnv FamInst.tcGetFamInstEnvs case m of Nothing -> TcRnMonad.liftIO $ throwIO (HscTypes.mkSrcErr (snd msgs)) Just x -> return x-#else- famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs-#endif allSyn <- Map.fromList <$> findSynthesizeAnnotations allBinderIds topSyn <- map fst <$> findSynthesizeAnnotations rootIds@@ -535,18 +515,7 @@ , tid `Set.member` allBenchIds -- indicate whether top entity is test bench ) - let reprs1 = lbReprs ++ reprs'-- annTime <-- extTime- `deepseq` length topEntities2- `deepseq` lbPrims- `deepseq` reprs1- `deepseq` primGuards- `deepseq` MonadUtils.liftIO Clock.getCurrentTime-- let annExtDiff = reportTimeDiff annTime extTime- MonadUtils.liftIO $ putStrLn $ "GHC: Parsing annotations took: " ++ annExtDiff+ let reprs1 = lbReprs <> Seq.fromList reprs' let famInstEnvs' = (fst famInstEnvs, modFamInstEnvs) allTCInsts = FamInstEnv.famInstEnvElts (fst famInstEnvs')@@ -570,12 +539,12 @@ knownConfMap = HashMap.fromList (zip knownConfNms knownConfDs) return ( allBinders- , lbClassOps- , lbUnlocatable+ , Map.assocs lbClassOps+ , Set.toList lbUnlocatable , famInstEnvs' , topEntities2- , lbPrims- , reprs1+ , toList lbPrims+ , toList reprs1 , primGuards , knownConfMap )@@ -648,16 +617,10 @@ :: (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -> Digraph.Node Unique.Unique (CoreSyn.CoreBndr,CoreSyn.CoreExpr) makeNode (b,e) =-#if MIN_VERSION_ghc(8,4,1) Digraph.DigraphNode (b,e) (Var.varUnique b) (UniqSet.nonDetKeysUniqSet (CoreFVs.exprSomeFreeVars Var.isId e))-#else- ((b,e)- ,Var.varUnique b- ,UniqSet.nonDetKeysUniqSet (CoreFVs.exprSomeFreeVars Var.isId e))-#endif makeBind :: Digraph.SCC (CoreSyn.CoreBndr,CoreSyn.CoreExpr)@@ -874,10 +837,6 @@ , Opt_DoEtaReduction -- We want eta-expansion , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid-#if !MIN_VERSION_ghc(8,6,0)- , Opt_Vectorise -- Don't care- , Opt_VectorisationAvoidance -- Don't care-#endif , Opt_RegsGraph -- Don't care , Opt_RegsGraph -- Don't care , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid@@ -977,11 +936,7 @@ rmPS hsm = hsm {GHC.hsmodDecls = (fmap . fmap) rmHSD (GHC.hsmodDecls hsm)} -- rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name-#if MIN_VERSION_ghc(8,6,0) rmHSD (GHC.TyClD x tyClDecl) = GHC.TyClD x (rmTyClD tyClDecl)-#else- rmHSD (GHC.TyClD tyClDecl) = GHC.TyClD (rmTyClD tyClDecl)-#endif rmHSD hsd = hsd -- rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name@@ -992,7 +947,6 @@ rmDataDefn hdf = hdf {GHC.dd_cons = (fmap . fmap) rmCD (GHC.dd_cons hdf)} -- rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name-#if MIN_VERSION_ghc(8,6,0) rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_res_ty = rmHsType (GHC.con_res_ty gadt) ,GHC.con_args = rmConDetails (GHC.con_args gadt) }@@ -1000,17 +954,7 @@ #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)}-#endif - -- type LHsSigType name = HsImplicitBndrs name (LHsType name)- -- rmSigType :: GHC.DataId name => GHC.LHsSigType name -> GHC.LHsSigType name-#if !MIN_VERSION_ghc(8,6,0)- rmSigType hsIB = hsIB {GHC.hsib_body = rmHsType (GHC.hsib_body hsIB)}-#endif- -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name]) -- rmConDetails :: _ => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name #if MIN_VERSION_ghc(9,0,0)@@ -1026,11 +970,7 @@ -- rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name) rmHsType = transform go where-#if MIN_VERSION_ghc(8,6,0) go (GHC.unLoc -> GHC.HsBangTy _ _ ty) = ty-#else- go (GHC.unLoc -> GHC.HsBangTy _ ty) = ty-#endif go ty = ty #if MIN_VERSION_ghc(9,0,0)
src-ghc/Clash/GHC/NetlistTypes.hs view
@@ -1,8 +1,9 @@ {-| Copyright : (C) 2013-2016, University of Twente,- 2016-2017, Myrtle Software Ltd+ 2016-2017, Myrtle Software Ltd,+ 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE)- Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+ Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-}@@ -45,8 +46,6 @@ :: Int -- ^ Integer width. The width Clash assumes an Integer to be (instead of it -- begin an arbitrarily large, runtime sized construct).- -> Bool- -- ^ Float support -> CustomReprs -- ^ Custom bit representations -> TyConMap@@ -54,7 +53,7 @@ -> Type -- ^ Type to convert to HWType -> State HWMap (Maybe (Either String FilteredHWType))-ghcTypeToHWType iw floatSupport = go+ghcTypeToHWType iw = go where -- returnN :: HWType -> returnN t = return (FilteredHWType t [])@@ -112,14 +111,14 @@ "GHC.Prim.Word#" -> returnN (Unsigned iw) "GHC.Prim.Int64#" -> returnN (Signed 64) "GHC.Prim.Word64#" -> returnN (Unsigned 64)- "GHC.Prim.Float#" | floatSupport -> returnN (BitVector 32)- "GHC.Prim.Double#" | floatSupport -> returnN (BitVector 64)+ "GHC.Prim.Float#" -> returnN (BitVector 32)+ "GHC.Prim.Double#" -> returnN (BitVector 64) "GHC.Prim.ByteArray#" -> throwE $ "Can't translate type: " ++ showPpr ty "GHC.Types.Bool" -> returnN Bool- "GHC.Types.Float" | floatSupport-> returnN (BitVector 32)- "GHC.Types.Double" | floatSupport -> returnN (BitVector 64)+ "GHC.Types.Float" -> returnN (BitVector 32)+ "GHC.Types.Double" -> returnN (BitVector 64) "GHC.Prim.~#" -> returnN (Void Nothing) "Clash.Signal.Internal.Signal" ->@@ -234,6 +233,12 @@ let filtered = [replicate sz1 (isVoid, fElHWTy)] return (FilteredHWType vecHWTy filtered) + "Clash.Explicit.BlockRam.Internal.MemBlob" -> do+ let [nTy, mTy] = args+ n0 <- liftE (tyNatSize m nTy)+ m0 <- liftE (tyNatSize m mTy)+ returnN (MemBlob (fromInteger n0) (fromInteger m0))+ "Clash.Sized.RTree.RTree" -> do let [szTy,elTy] = args sz0 <- liftE (tyNatSize m szTy)@@ -254,6 +259,7 @@ return (FilteredHWType vecHWTy filtered) "String" -> returnN String+ "GHC.Prim.Addr#" -> returnN String "GHC.Types.[]" -> case tyView (head args) of (TyConApp (nameOcc -> "GHC.Types.Char") []) -> returnN String _ -> throwE $ "Can't translate type: " ++ showPpr ty
src-ghc/Clash/GHC/PartialEval/Eval.hs view
@@ -1,5 +1,5 @@ {-|-Copyright : (C) 2020, QBayLogic B.V.+Copyright : (C) 2020-2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -23,7 +23,6 @@ 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 (..))@@ -38,19 +37,19 @@ #endif import Clash.Core.DataCon (DataCon(..))+import Clash.Core.HasType 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 qualified Clash.Normalize.Primitives as NP (undefined) import Clash.Unique (lookupUniqMap') -- | Evaluate a term to WHNF.@@ -65,7 +64,7 @@ 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+ Let bs x -> evalLet bs x Case x ty alts -> evalCase x ty alts Cast x a b -> evalCast x a b Tick tick x -> evalTick tick x@@ -249,33 +248,30 @@ 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)+evalLet :: Bind Term -> Term -> Eval Value+evalLet (NonRec i x) body = do+ iTy <- evalType (varType i)+ eX <- delayEval x+ wfX <- workFreeValue eX - case keep of- [] -> pure eX- _ -> pure (VNeutral (NeLetrec keep eX))- where- evalBind (i, y) = do- iTy <- evalType (varType i)- eY <- delayEval y+ eBody <- withId i eX (eval body) - pure (i { varType = iTy }, eY)+ -- Only keep the let binding if it performs work.+ if wfX+ then pure eBody+ else pure (VNeutral (NeLet (NonRec i{varType=iTy} eX) eBody)) - evalScc (k, i) = \case- AcyclicSCC y -> do- eY <- evalBind y- workFree <- workFreeValue (snd eY)+evalLet (Rec xs) body = do+ binds <- traverse evalBind xs+ eBody <- withIds binds (eval body) - if workFree then pure (k, eY:i) else pure (eY:k, i)+ pure (VNeutral (NeLet (Rec binds) eBody))+ where+ evalBind (i, x) = do+ iTy <- evalType (varType i)+ eX <- delayEval x - CyclicSCC ys -> do- eYs <- traverse evalBind ys- pure (eYs <> k, i)+ pure (i{varType=iTy}, eX) evalCase :: Term -> Type -> [Alt] -> Eval Value evalCase term ty as = do@@ -295,7 +291,7 @@ -- If the subject is undefined, the whole expression is undefined. case isUndefined forcedSubject of- True -> eval (Util.undefinedTm ty)+ True -> eval (TyApp (Prim NP.undefined) ty) False -> case stripValue forcedSubject of -- Known literal: attempt to match or throw an error.@@ -342,9 +338,9 @@ -- A case of let: Pull out the let expression if possible and attempt -- caseCon on the new case expression.- VNeutral (NeLetrec bindings innerSubject) -> do+ VNeutral (NeLet bindings innerSubject) -> do newCase <- caseCon innerSubject ty alts- pure (VNeutral (NeLetrec bindings newCase))+ pure (VNeutral (NeLet bindings newCase)) -- There is no way to continue evaluating the case, do nothing. -- TODO elimExistentials here.@@ -569,16 +565,16 @@ 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)+ VNeutral (NeLet bs x) | canApply -> do inner <- apply x arg- pure (VNeutral (NeLetrec bs inner))+ pure (VNeutral (NeLet 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))+ pure (VNeutral (NeLet bs (VNeutral (NeLet (NonRec var arg) inner)))) -- If the LHS of application is neutral, make a letrec around the neutral -- application if the argument performs work.@@ -588,7 +584,7 @@ varTy <- evalType (valueType tcm arg) var <- getUniqueId "workArg" varTy let inner = VNeutral (NeApp neu (VNeutral (NeVar var)))- pure (VNeutral (NeLetrec [(var, arg)] inner))+ pure (VNeutral (NeLet (NonRec 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.@@ -596,13 +592,13 @@ | canApply -> setLocalEnv env $ withId i arg (eval x) | otherwise -> setLocalEnv env $ do inner <- withId i arg (eval x)- pure (VNeutral (NeLetrec [(i, arg)] inner))+ pure (VNeutral (NeLet (NonRec 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+ -- TODO Write an instance for InferType Value and use that instead+ valueType tcm = inferCoreTypeOf tcm . asTerm applyTy :: Value -> Type -> Eval Value applyTy val ty = do
src-ghc/Clash/GHC/PartialEval/Quote.hs view
@@ -1,5 +1,5 @@ {-|-Copyright : (C) 2020, QBayLogic B.V.+Copyright : (C) 2020-2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -18,7 +18,7 @@ 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.Term (Bind(..), Term, PrimInfo, TickInfo, Pat) import Clash.Core.Type (Type(VarTy)) import Clash.Core.Var (Id, TyVar) @@ -41,7 +41,7 @@ NePrim pr args -> quoteNePrim pr args NeApp x y -> quoteNeApp x y NeTyApp x ty -> quoteNeTyApp x ty- NeLetrec bs x -> quoteNeLetrec bs x+ NeLet bs x -> quoteNeLet bs x NeCase x ty alts -> quoteNeCase x ty alts quoteArgs :: Args Value -> Eval (Args Normal)@@ -50,8 +50,9 @@ quoteAlts :: [(Pat, Value)] -> Eval [(Pat, Normal)] quoteAlts = traverse (bitraverse pure quote) -quoteBinders :: [(Id, Value)] -> Eval [(Id, Normal)]-quoteBinders = traverse (bitraverse pure quote)+quoteBind :: Bind Value -> Eval (Bind Normal)+quoteBind (NonRec i x) = NonRec i <$> quote x+quoteBind (Rec xs) = Rec <$> traverse (bitraverse pure quote) xs quoteData :: DataCon -> Args Value -> LocalEnv -> Eval Normal quoteData dc args env = setLocalEnv env (NData dc <$> quoteArgs args)@@ -90,9 +91,12 @@ 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)+quoteNeLet :: Bind Value -> Value -> Eval (Neutral Normal)+quoteNeLet bs x =+ withIds (bindToList bs) (NeLet <$> quoteBind bs <*> quote x)+ where+ bindToList (NonRec i e) = [(i, e)]+ bindToList (Rec xs) = xs quoteNeCase :: Value -> Type -> [(Pat, Value)] -> Eval (Neutral Normal) quoteNeCase x ty alts =