From f80ac3b27dc265f8f022b81b6b5c033ad0e32468 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Sat, 19 Apr 2025 15:56:37 +0200 Subject: [PATCH 01/13] Add GHC 9.12 support to `clash-prelude` --- cabal.project | 2 +- clash-prelude/clash-prelude.cabal | 6 +++--- .../src/Clash/Annotations/BitRepresentation.hs | 13 +++++++++++-- .../Annotations/BitRepresentation/Deriving.hs | 7 ++++++- .../Annotations/BitRepresentation/Internal.hs | 17 ++++++++++++++--- clash-prelude/src/Clash/Promoted/Nat.hs | 6 ++++-- clash-prelude/src/Clash/Signal/Internal.hs | 4 ++++ clash-prelude/src/Clash/Sized/RTree.hs | 4 ++-- clash-prelude/src/Clash/Sized/Vector.hs | 10 +++++----- clash-prelude/src/Clash/XException.hs | 4 ++-- 10 files changed, 52 insertions(+), 21 deletions(-) diff --git a/cabal.project b/cabal.project index 67281bb607..e06d7bf79d 100644 --- a/cabal.project +++ b/cabal.project @@ -15,7 +15,7 @@ write-ghc-environment-files: always -- index state, to go along with the cabal.project.freeze file. update the index -- state by running `cabal update` twice and looking at the index state it -- displays to you (as the second update will be a no-op) -index-state: 2025-02-10T14:25:49Z +index-state: 2025-04-19T07:34:07Z -- For some reason the `clash-testsuite` executable fails to run without -- this, as it cannot find the related library... diff --git a/clash-prelude/clash-prelude.cabal b/clash-prelude/clash-prelude.cabal index 8871d82623..df2d24ab61 100644 --- a/clash-prelude/clash-prelude.cabal +++ b/clash-prelude/clash-prelude.cabal @@ -324,13 +324,13 @@ Library binary >= 0.8.5 && < 0.11, bytestring >= 0.10.8 && < 0.13, constraints >= 0.9 && < 1.0, - containers >= 0.4.0 && < 0.8, + containers >= 0.4.0 && < 0.9, data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.7 && < 0.9, deepseq >= 1.4.1.0 && < 1.6, distributive >= 0.1 && < 1.0, extra >= 1.6.17 && < 1.9, - ghc-prim >= 0.5.1.0 && < 0.12, + ghc-prim >= 0.5.1.0 && < 0.14, ghc-typelits-extra >= 0.4 && < 0.5, ghc-typelits-knownnat >= 0.7.2 && < 0.8, ghc-typelits-natnormalise >= 0.7.2 && < 0.8, @@ -344,7 +344,7 @@ Library singletons >= 2.0 && < 3.1, string-interpolate ^>= 0.3, tagged >= 0.8 && < 0.9, - template-haskell >= 2.12.0.0 && < 2.23, + template-haskell >= 2.12.0.0 && < 2.24, th-abstraction >= 0.2.10 && < 0.8.0, th-lift >= 0.7.0 && < 0.9, th-orphans >= 0.13.1 && < 1.0, diff --git a/clash-prelude/src/Clash/Annotations/BitRepresentation.hs b/clash-prelude/src/Clash/Annotations/BitRepresentation.hs index ca38976303..897f708f23 100644 --- a/clash-prelude/src/Clash/Annotations/BitRepresentation.hs +++ b/clash-prelude/src/Clash/Annotations/BitRepresentation.hs @@ -8,6 +8,7 @@ bit representation for a data type. See @DataReprAnn@ for documentation. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -28,7 +29,9 @@ module Clash.Annotations.BitRepresentation ) where import Data.Data (Data) +#if __GLASGOW_HASKELL__ <= 910 import Data.Typeable (Typeable) +#endif import Language.Haskell.TH.Instances () import qualified Language.Haskell.TH.Lift () import qualified Language.Haskell.TH.Syntax as TH @@ -112,7 +115,10 @@ data DataReprAnn = Size -- Constructors: [ConstrRepr] - deriving (Show, Data, Typeable, Eq, Generic, TH.Lift) + deriving (Show, Data, Eq, Generic, TH.Lift) +#if __GLASGOW_HASKELL__ <= 910 + deriving Typeable +#endif -- | Annotation for constructors. Indicates how to match this constructor based -- off of the whole datatype. @@ -126,4 +132,7 @@ data ConstrRepr = Value -- Masks for fields. Indicates where fields are stored: [FieldAnn] - deriving (Show, Data, Typeable, Eq, Generic, TH.Lift) + deriving (Show, Data, Eq, Generic, TH.Lift) +#if __GLASGOW_HASKELL__ <= 910 + deriving Typeable +#endif diff --git a/clash-prelude/src/Clash/Annotations/BitRepresentation/Deriving.hs b/clash-prelude/src/Clash/Annotations/BitRepresentation/Deriving.hs index 718b3fa8d7..a018921be2 100644 --- a/clash-prelude/src/Clash/Annotations/BitRepresentation/Deriving.hs +++ b/clash-prelude/src/Clash/Annotations/BitRepresentation/Deriving.hs @@ -74,7 +74,9 @@ import Data.Data (Data) import Data.Containers.ListUtils (nubOrd) import Data.List (mapAccumL, zipWith4, sortOn, partition, uncons) +#if __GLASGOW_HASKELL__ < 912 import Data.Typeable (Typeable) +#endif import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Set as Set @@ -93,7 +95,10 @@ data BitMaskOrigin -- ^ Constructor bit should be stored externally | Embedded BitMask Value -- ^ Constructor bit should be stored in one of the constructor's fields - deriving (Show, Data, Typeable, Lift) + deriving (Show, Data, Lift) +#if __GLASGOW_HASKELL__ < 912 + deriving (Typeable) +#endif isExternal :: BitMaskOrigin -> Bool isExternal External = True diff --git a/clash-prelude/src/Clash/Annotations/BitRepresentation/Internal.hs b/clash-prelude/src/Clash/Annotations/BitRepresentation/Internal.hs index 835665eda2..e7d5006bd5 100644 --- a/clash-prelude/src/Clash/Annotations/BitRepresentation/Internal.hs +++ b/clash-prelude/src/Clash/Annotations/BitRepresentation/Internal.hs @@ -31,7 +31,9 @@ import Data.Hashable (Hashable) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Text as Text +#if __GLASGOW_HASKELL__ <= 910 import Data.Typeable (Typeable) +#endif import qualified Language.Haskell.TH.Syntax as TH import GHC.Generics (Generic) import GHC.Stack (HasCallStack) @@ -47,7 +49,10 @@ data Type' -- ^ Numeral literal (used in BitVector 10, for example) | SymLitTy' Text.Text -- ^ Symbol literal (used in for example (Signal "System" Int)) - deriving (Generic, NFData, Eq, Typeable, Hashable, Ord, Show) + deriving (Generic, NFData, Eq, Hashable, Ord, Show) +#if __GLASGOW_HASKELL__ <= 910 + deriving Typeable +#endif -- | Internal version of DataRepr data DataRepr' = DataRepr' @@ -58,7 +63,10 @@ data DataRepr' = DataRepr' , drConstrs :: [ConstrRepr'] -- ^ Constructors } - deriving (Show, Generic, NFData, Eq, Typeable, Hashable, Ord) + deriving (Show, Generic, NFData, Eq, Hashable, Ord) +#if __GLASGOW_HASKELL__ <= 910 + deriving Typeable +#endif -- | Internal version of ConstrRepr data ConstrRepr' = ConstrRepr' @@ -73,7 +81,10 @@ data ConstrRepr' = ConstrRepr' , crFieldAnns :: [FieldAnn] -- ^ Indicates where fields are stored } - deriving (Show, Generic, NFData, Eq, Typeable, Ord, Hashable) + deriving (Show, Generic, NFData, Eq, Ord, Hashable) +#if __GLASGOW_HASKELL__ <= 910 + deriving Typeable +#endif constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr' constrReprToConstrRepr' n (ConstrRepr name mask value fieldanns) = diff --git a/clash-prelude/src/Clash/Promoted/Nat.hs b/clash-prelude/src/Clash/Promoted/Nat.hs index 8ec2cf7352..f3f78fdc49 100644 --- a/clash-prelude/src/Clash/Promoted/Nat.hs +++ b/clash-prelude/src/Clash/Promoted/Nat.hs @@ -248,7 +248,7 @@ powUNat x (USucc y) = mulUNat x (powUNat x y) -- __NB__: Not synthesizable predUNat :: UNat (n+1) -> UNat n predUNat (USucc x) = x -#if __GLASGOW_HASKELL__ != 902 +#if __GLASGOW_HASKELL__ != 902 && __GLASGOW_HASKELL__ < 912 predUNat UZero = error "predUNat: impossible: 0 minus 1, -1 is not a natural number" #endif @@ -259,7 +259,9 @@ predUNat UZero = subUNat :: UNat (m+n) -> UNat n -> UNat m subUNat x UZero = x subUNat (USucc x) (USucc y) = subUNat x y +#if __GLASGOW_HASKELL__ < 912 subUNat UZero _ = error "subUNat: impossible: 0 + (n + 1) ~ 0" +#endif -- | Predecessor of a singleton natural number predSNat :: SNat (a+1) -> SNat (a) @@ -535,7 +537,7 @@ div2Sub1BNat _ = error "div2Sub1BNat: impossible: 2*n+1 ~ 2*n" -- -- __NB__: Not synthesizable log2BNat :: BNat (2^n) -> BNat n -#if __GLASGOW_HASKELL__ != 902 +#if __GLASGOW_HASKELL__ != 902 && __GLASGOW_HASKELL__ < 912 log2BNat BT = error "log2BNat: log2(0) not defined" #endif log2BNat (B1 x) = case stripZeros x of diff --git a/clash-prelude/src/Clash/Signal/Internal.hs b/clash-prelude/src/Clash/Signal/Internal.hs index 3a9ca3bd27..683b84f01b 100644 --- a/clash-prelude/src/Clash/Signal/Internal.hs +++ b/clash-prelude/src/Clash/Signal/Internal.hs @@ -181,7 +181,9 @@ module Clash.Signal.Internal where import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef) +#if __GLASGOW_HASKELL__ < 912 import Type.Reflection (Typeable) +#endif import Control.Arrow.Transformer.Automaton #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -344,7 +346,9 @@ data DomainConfiguration , _resetPolarity :: ResetPolarity -- ^ Whether resets are active high or active low } +#if __GLASGOW_HASKELL__ < 912 deriving (Typeable) +#endif -- | Helper type family for 'DomainPeriod' type family DomainConfigurationPeriod (config :: DomainConfiguration) :: Nat where diff --git a/clash-prelude/src/Clash/Sized/RTree.hs b/clash-prelude/src/Clash/Sized/RTree.hs index 24f7b8966a..b46aac201d 100644 --- a/clash-prelude/src/Clash/Sized/RTree.hs +++ b/clash-prelude/src/Clash/Sized/RTree.hs @@ -124,7 +124,7 @@ instance NFData a => NFData (RTree d a) where textract :: RTree 0 a -> a textract (RLeaf x) = x -#if __GLASGOW_HASKELL__ != 902 +#if __GLASGOW_HASKELL__ != 902 && __GLASGOW_HASKELL__ < 912 textract (RBranch _ _) = error $ "textract: nodes hold no values" #endif -- See: https://github.com/clash-lang/clash-compiler/pull/2511 @@ -133,7 +133,7 @@ textract (RBranch _ _) = error $ "textract: nodes hold no values" tsplit :: RTree (d+1) a -> (RTree d a,RTree d a) tsplit (RBranch l r) = (l,r) -#if __GLASGOW_HASKELL__ != 902 +#if __GLASGOW_HASKELL__ != 902 && __GLASGOW_HASKELL__ < 912 tsplit (RLeaf _) = error $ "tsplit: leaf is atomic" #endif -- See: https://github.com/clash-lang/clash-compiler/pull/2511 diff --git a/clash-prelude/src/Clash/Sized/Vector.hs b/clash-prelude/src/Clash/Sized/Vector.hs index fcdbe2bc85..011bb57b6e 100644 --- a/clash-prelude/src/Clash/Sized/Vector.hs +++ b/clash-prelude/src/Clash/Sized/Vector.hs @@ -452,7 +452,7 @@ singleton = (`Cons` Nil) -} head :: Vec (n + 1) a -> a head (x `Cons` _) = x -#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +#if __GLASGOW_HASKELL__ < 902 || __GLASGOW_HASKELL__ >= 904 && __GLASGOW_HASKELL__ < 912 head xs = unreachable xs where unreachable :: forall n a. 1 <= n => Vec n a -> a @@ -504,7 +504,7 @@ head xs = unreachable xs -} tail :: Vec (n + 1) a -> Vec n a tail (_ `Cons` xr) = xr -#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +#if __GLASGOW_HASKELL__ < 902 || __GLASGOW_HASKELL__ >= 904 && __GLASGOW_HASKELL__ < 912 tail xs = unreachable xs where unreachable :: forall n a. 1 <= n => Vec n a -> Vec (n - 1) a @@ -557,7 +557,7 @@ tail xs = unreachable xs last :: Vec (n + 1) a -> a last (x `Cons` Nil) = x last (_ `Cons` y `Cons` xr) = last (y `Cons` xr) -#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +#if __GLASGOW_HASKELL__ < 902 || __GLASGOW_HASKELL__ >= 904 && __GLASGOW_HASKELL__ < 912 last xs = unreachable xs where unreachable :: 1 <= n => Vec n a -> a @@ -610,7 +610,7 @@ last xs = unreachable xs init :: Vec (n + 1) a -> Vec n a init (_ `Cons` Nil) = Nil init (x `Cons` y `Cons` xr) = x `Cons` init (y `Cons` xr) -#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +#if __GLASGOW_HASKELL__ < 902 || __GLASGOW_HASKELL__ >= 904 && __GLASGOW_HASKELL__ < 912 init xs = unreachable xs where unreachable :: 1 <= n => Vec n a -> Vec (n - 1) a @@ -2617,7 +2617,7 @@ dtfold _ f g = go (SNat :: SNat k) sn' = sn `subSNat` d1 (xsL,xsR) = splitAt (pow2SNat sn') xs in g sn' (go sn' xsL) (go sn' xsR) -#if !MIN_VERSION_base(4,16,0) || MIN_VERSION_base(4,17,0) +#if __GLASGOW_HASKELL__ < 902 || __GLASGOW_HASKELL__ >= 904 && __GLASGOW_HASKELL__ < 912 go _ Nil = case (const Dict :: forall m. Proxy m -> Dict (1 <= 2 ^ m)) (Proxy @n) of {} diff --git a/clash-prelude/src/Clash/XException.hs b/clash-prelude/src/Clash/XException.hs index 8e654d8695..0a8dbbb7f2 100644 --- a/clash-prelude/src/Clash/XException.hs +++ b/clash-prelude/src/Clash/XException.hs @@ -148,7 +148,7 @@ errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStac -- X: QQ -- CallStack (from HasCallStack): -- errorX, called at ... --- +-- ... xToErrorCtx :: String -> a -> a xToErrorCtx ctx a = unsafeDupablePerformIO (catch (evaluate a >> return a) @@ -209,7 +209,7 @@ xToErrorCtx ctx a = unsafeDupablePerformIO -- X: QQ -- CallStack (from HasCallStack): -- errorX, called at ... --- +-- ... xToError :: HasCallStack => a -> a xToError = xToErrorCtx (prettyCallStack callStack) {-# INLINE xToError #-} From 0f48d6e5873a7a73503d33166c6f0f2bfd4f0998 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Sat, 19 Apr 2025 16:02:07 +0200 Subject: [PATCH 02/13] Add GHC 9.12 support to `clash-lib` --- clash-lib/clash-lib.cabal | 6 +++--- clash-lib/src/Clash/Netlist/Types.hs | 7 ++++++- clash-lib/src/Data/Text/Prettyprint/Doc/Extra.hs | 4 ++-- 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/clash-lib/clash-lib.cabal b/clash-lib/clash-lib.cabal index f955862573..f3f9db02e3 100644 --- a/clash-lib/clash-lib.cabal +++ b/clash-lib/clash-lib.cabal @@ -152,7 +152,7 @@ Library binary >= 0.8.5 && < 0.11, bytestring >= 0.10.0.2 && < 0.13, clash-prelude == 1.9.0, - containers >= 0.5.0.0 && < 0.8, + containers >= 0.5.0.0 && < 0.9, cryptohash-sha256 >= 0.11 && < 0.12, data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.7 && < 0.9, @@ -162,7 +162,7 @@ Library exceptions >= 0.8.3 && < 0.11.0, extra >= 1.6.17 && < 1.9, filepath >= 1.3.0.1 && < 1.6, - ghc >= 8.10.0 && < 9.11, + ghc >= 8.10.0 && < 9.13, ghc-boot, ghc-boot-th, ghc-prim, @@ -178,7 +178,7 @@ Library pretty-show >= 1.9 && < 2.0, primitive >= 0.5.0.1 && < 1.0, string-interpolate ^>= 0.3, - template-haskell >= 2.8.0.0 && < 2.23, + template-haskell >= 2.8.0.0 && < 2.24, temporary >= 1.2.1 && < 1.4, terminal-size >= 0.3 && < 0.4, text >= 1.2.2 && < 2.2, diff --git a/clash-lib/src/Clash/Netlist/Types.hs b/clash-lib/src/Clash/Netlist/Types.hs index 36b059b621..11dc19973d 100644 --- a/clash-lib/src/Clash/Netlist/Types.hs +++ b/clash-lib/src/Clash/Netlist/Types.hs @@ -57,7 +57,9 @@ import Data.Monoid (Ap(..)) import qualified Data.Set as Set import Data.Text (Text) +#if __GLASGOW_HASKELL__ <= 910 import Data.Typeable (Typeable) +#endif import Data.Text.Prettyprint.Doc.Extra (Doc) import GHC.Generics (Generic) import GHC.Stack @@ -829,7 +831,10 @@ data Bit | L -- ^ Low | U -- ^ Undefined | Z -- ^ High-impedance - deriving (Eq,Show,Typeable,Lift) + deriving (Eq,Show,Lift) +#if __GLASGOW_HASKELL__ <= 910 + deriving Typeable +#endif toBit :: Integer -- ^ mask diff --git a/clash-lib/src/Data/Text/Prettyprint/Doc/Extra.hs b/clash-lib/src/Data/Text/Prettyprint/Doc/Extra.hs index 40bb3ae551..d5c1a5f348 100644 --- a/clash-lib/src/Data/Text/Prettyprint/Doc/Extra.hs +++ b/clash-lib/src/Data/Text/Prettyprint/Doc/Extra.hs @@ -15,8 +15,8 @@ where import Control.Applicative import Data.String (IsString (..)) -import Data.Text as T -import Data.Text.Lazy as LT +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT #if MIN_VERSION_prettyprinter(1,7,0) import qualified Prettyprinter as PP From f7c428c1772bf3e7b6c569fd71b8887a66957dd0 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Sat, 19 Apr 2025 16:02:33 +0200 Subject: [PATCH 03/13] Add GHC 9.12 support to `clash-lib-hedgehog` --- clash-lib-hedgehog/clash-lib-hedgehog.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/clash-lib-hedgehog/clash-lib-hedgehog.cabal b/clash-lib-hedgehog/clash-lib-hedgehog.cabal index b62a101c34..082b271652 100644 --- a/clash-lib-hedgehog/clash-lib-hedgehog.cabal +++ b/clash-lib-hedgehog/clash-lib-hedgehog.cabal @@ -49,7 +49,7 @@ library Clash.Hedgehog.Unique build-depends: - containers >= 0.5.0.0 && < 0.8, + containers >= 0.5.0.0 && < 0.9, data-binary-ieee754 >= 0.4.4 && < 0.6, fakedata >= 1.0.2 && < 1.1, ghc-typelits-knownnat >= 0.7.2 && < 0.8, @@ -61,6 +61,6 @@ library primitive >= 0.5.0.1 && < 1.0, text >= 1.2.2 && < 2.2, transformers >= 0.5.2.0 && < 0.7, - ghc >= 8.10.0 && < 9.11, + ghc >= 8.10.0 && < 9.13, clash-lib == 1.9.0, From acd80762ed79c620daac6e0c467921cf75f11ef3 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Sun, 20 Apr 2025 23:59:24 +0200 Subject: [PATCH 04/13] Add source for GHC 9.12 executable --- clash-ghc/src-bin-9.12/Clash/GHCi/Leak.hs | 85 + clash-ghc/src-bin-9.12/Clash/GHCi/UI.hs | 4737 +++++++++++++++++ .../src-bin-9.12/Clash/GHCi/UI/Exception.hs | 141 + clash-ghc/src-bin-9.12/Clash/GHCi/UI/Info.hs | 402 ++ clash-ghc/src-bin-9.12/Clash/GHCi/UI/Monad.hs | 579 ++ clash-ghc/src-bin-9.12/Clash/GHCi/Util.hs | 16 + clash-ghc/src-bin-9.12/Clash/Main.hs | 1162 ++++ 7 files changed, 7122 insertions(+) create mode 100644 clash-ghc/src-bin-9.12/Clash/GHCi/Leak.hs create mode 100644 clash-ghc/src-bin-9.12/Clash/GHCi/UI.hs create mode 100644 clash-ghc/src-bin-9.12/Clash/GHCi/UI/Exception.hs create mode 100644 clash-ghc/src-bin-9.12/Clash/GHCi/UI/Info.hs create mode 100644 clash-ghc/src-bin-9.12/Clash/GHCi/UI/Monad.hs create mode 100644 clash-ghc/src-bin-9.12/Clash/GHCi/Util.hs create mode 100644 clash-ghc/src-bin-9.12/Clash/Main.hs diff --git a/clash-ghc/src-bin-9.12/Clash/GHCi/Leak.hs b/clash-ghc/src-bin-9.12/Clash/GHCi/Leak.hs new file mode 100644 index 0000000000..51e3958ba2 --- /dev/null +++ b/clash-ghc/src-bin-9.12/Clash/GHCi/Leak.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RecordWildCards, LambdaCase #-} +module GHCi.Leak + ( LeakIndicators + , getLeakIndicators + , checkLeakIndicators + ) where + +import Control.Monad +import Data.Bits +import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) +import GHC +import GHC.Ptr (Ptr (..)) +import GHCi.Util +import GHC.Driver.Env +import GHC.Driver.Ppr +import GHC.Utils.Outputable +import GHC.Unit.Module.ModDetails +import GHC.Unit.Home.ModInfo +import GHC.Platform (target32Bit) +import GHC.Linker.Types +import Prelude +import System.Mem +import System.Mem.Weak +import GHC.Types.Unique.DFM +import Control.Exception + +-- Checking for space leaks in GHCi. See #15111, and the +-- -fghci-leak-check flag. + +data LeakIndicators = LeakIndicators [LeakModIndicators] + +data LeakModIndicators = LeakModIndicators + { leakMod :: Weak HomeModInfo + , leakIface :: Weak ModIface + , leakDetails :: Weak ModDetails + , leakLinkable :: [Maybe (Weak Linkable)] + } + +-- | Grab weak references to some of the data structures representing +-- the currently loaded modules. +getLeakIndicators :: HscEnv -> IO LeakIndicators +getLeakIndicators hsc_env = + fmap LeakIndicators $ + forM (eltsUDFM (hsc_HPT hsc_env)) $ \hmi@HomeModInfo{..} -> do + leakMod <- mkWeakPtr hmi Nothing + leakIface <- mkWeakPtr hm_iface Nothing + leakDetails <- mkWeakPtr hm_details Nothing + leakLinkable <- mkWeakLinkables hm_linkable + return $ LeakModIndicators{..} + where + mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)] + mkWeakLinkables (HomeModLinkable mbc mo) = + mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo] + +-- | Look at the LeakIndicators collected by an earlier call to +-- `getLeakIndicators`, and print messasges if any of them are still +-- alive. +checkLeakIndicators :: DynFlags -> LeakIndicators -> IO () +checkLeakIndicators dflags (LeakIndicators leakmods) = do + performGC + forM_ leakmods $ \LeakModIndicators{..} -> do + deRefWeak leakMod >>= \case + Nothing -> return () + Just hmi -> + report ("HomeModInfo for " ++ + showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi) + deRefWeak leakIface >>= \case + Nothing -> return () + Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface) + deRefWeak leakDetails >>= report "ModDetails" + forM_ leakLinkable $ \l -> forM_ l $ \l' -> deRefWeak l' >>= report "Linkable" + where + report :: String -> Maybe a -> IO () + report _ Nothing = return () + report msg (Just a) = do + addr <- anyToPtr a + putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++ + show (maskTagBits addr)) + + tagBits + | target32Bit (targetPlatform dflags) = 2 + | otherwise = 3 + + maskTagBits :: Ptr a -> Ptr a + maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1)) diff --git a/clash-ghc/src-bin-9.12/Clash/GHCi/UI.hs b/clash-ghc/src-bin-9.12/Clash/GHCi/UI.hs new file mode 100644 index 0000000000..a802e43bd1 --- /dev/null +++ b/clash-ghc/src-bin-9.12/Clash/GHCi/UI.hs @@ -0,0 +1,4737 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS -fno-warn-name-shadowing #-} +-- This module does a lot of it + +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GHCi.UI ( + interactiveUI, + GhciSettings(..), + defaultGhciSettings, + ghciCommands, + ghciWelcomeMsg + ) where + +-- GHCi +import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' ) +import GHCi.UI.Monad hiding ( args, runStmt ) +import GHCi.UI.Info +import GHCi.UI.Exception +import GHC.Runtime.Debugger +import GHC.Runtime.Eval (mkTopLevEnv) + +-- The GHC interface +import GHC.Runtime.Interpreter +import GHCi.RemoteTypes +import GHCi.BreakArray( breakOn, breakOff ) +import GHC.ByteCode.Types +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.PatSyn +import GHC.Driver.Flags +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Phases +import GHC.Driver.Session as DynFlags +import GHC.Driver.Ppr hiding (printForUser) +import GHC.Utils.Error hiding (traceCmd) +import GHC.Driver.Monad ( modifySession ) +import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) ) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Diagnostic +import qualified GHC +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), + Resume, SingleStep, Ghc, + GetDocsFailure(..), pushLogHookM, + getModuleGraph, handleSourceError, ms_mod ) +import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation) +import GHC.Hs.ImpExp +import GHC.Hs +import GHC.Driver.Env +import GHC.Runtime.Context +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr +import GHC.Core.TyCo.Ppr +import GHC.Types.SafeHaskell ( getSafeMode ) +import GHC.Types.SourceError ( SourceError ) +import GHC.Types.Name +import GHC.Types.Breakpoint +import GHC.Types.Var ( varType ) +import GHC.Iface.Syntax ( showToHeader ) +import GHC.Builtin.Names +import GHC.Builtin.Types( stringTyCon_RDR ) +import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName, greName, globalRdrEnvElts) +import GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Parser.Lexer as Lexer +import GHC.Parser.Header ( toArgs ) +import qualified GHC.Parser.Header as Header +import GHC.Types.PkgQual + +import GHC.Unit +import GHC.Unit.Finder as Finder +import GHC.Unit.Module.Graph (filterToposortToModules) +import GHC.Unit.Module.ModSummary + +import GHC.Data.StringBuffer +import GHC.Utils.Outputable +import GHC.Utils.Logger + +-- Other random utilities +import GHC.Types.Basic hiding ( isTopLevel ) +import GHC.Settings.Config +import GHC.Data.Graph.Directed +import GHC.Utils.Encoding +import GHC.Data.FastString +import qualified GHC.Linker.Loader as Loader +import GHC.Data.Maybe ( expectJust ) +import GHC.Types.Name.Set +import GHC.Utils.Panic hiding ( showException, try ) +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt +import qualified GHC.Data.Strict as Strict +import GHC.Types.Error + +-- Haskell Libraries +import System.Console.Haskeline as Haskeline + +import Control.Applicative hiding (empty) +import Control.DeepSeq (deepseq) +import Control.Monad as Monad +import Control.Monad.Catch as MC +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import Data.Array +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Function +import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) +import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy, + isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as S +import Data.Maybe +import qualified Data.Map as M +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Time.LocalTime ( getZonedTime ) +import Data.Time.Format ( formatTime, defaultTimeLocale ) +import Data.Version ( showVersion ) +import qualified Data.Semigroup as S +import Prelude hiding ((<>)) + +import GHC.Utils.Exception as Exception hiding (catch, mask, handle) +import Foreign hiding (void) +import GHC.Stack hiding (SrcLoc(..)) +import GHC.Unit.Env +import GHC.Unit.Home.ModInfo + +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.Info +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) +import Text.Read.Lex (isSymbolChar) + +import Unsafe.Coerce + +#if !defined(mingw32_HOST_OS) +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) + +import GHCi.Leak +import qualified GHC.Unit.Module.Graph as GHC + +----------------------------------------------------------------------------- + +data GhciSettings = GhciSettings { + availableCommands :: [Command], + shortHelpText :: String, + fullHelpText :: String, + defPrompt :: PromptFunction, + defPromptCont :: PromptFunction + } + +defaultGhciSettings :: GhciSettings +defaultGhciSettings = + GhciSettings { + availableCommands = ghciCommands, + shortHelpText = defShortHelpText, + defPrompt = default_prompt, + defPromptCont = default_prompt_cont, + fullHelpText = defFullHelpText + } + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": https://www.haskell.org/ghc/ :? for help" + +ghciCommands :: [Command] +ghciCommands = map mkCmd [ + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeBreakpoint), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoingMulti' changeDirectory, completeFilename), + ("continue", keepGoing continueCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("disable", keepGoing disableCmd, noCompletion), + ("doc", keepGoing' docCmd, completeIdentifier), + ("edit", keepGoingMulti' editFile, completeFilename), + ("enable", keepGoing enableCmd, noCompletion), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoingMulti help, noCompletion), + ("history", keepGoingMulti historyCmd, noCompletion), + ("info", keepGoingMulti' (info False), completeIdentifier), + ("info!", keepGoingMulti' (info True), completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), + ("ignore", keepGoing ignoreCmd, noCompletion), + ("kind", keepGoingMulti' (kindOfType False), completeIdentifier), + ("kind!", keepGoingMulti' (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", keepGoingMulti' reloadModule, noCompletion), + ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), + ("set", keepGoingMulti setCmd, completeSetOptions), + ("seti", keepGoingMulti setiCmd, completeSeti), + ("show", keepGoingMulti' showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoingMulti' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("unadd", keepGoingPaths unAddModule, completeFilename), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions), + ("where", keepGoing whereCmd, noCompletion), + ("instances", keepGoing' instancesCmd, completeExpression) + ] ++ map mkCmdHidden [ -- hidden commands + ("all-types", keepGoing' allTypesCmd), + ("complete", keepGoing completeCmd), + ("loc-at", keepGoing' locAtCmd), + ("type-at", keepGoing' typeAtCmd), + ("uses", keepGoing' usesCmd) + ] + where + mkCmd (n,a,c) = Command { cmdName = n + , cmdAction = a + , cmdHidden = False + , cmdCompletionFunc = c + } + + mkCmdHidden (n,a) = Command { cmdName = n + , cmdAction = a + , cmdHidden = True + , cmdCompletionFunc = noCompletion + } + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +word_break_chars :: String +word_break_chars = spaces ++ specials ++ symbols + +word_break_chars_pred :: Char -> Bool +word_break_chars_pred '.' = False +word_break_chars_pred c = c `elem` (spaces ++ specials) || isSymbolChar c + +symbols, specials, spaces :: String +symbols = "!#$%&*+/<=>?@\\^|-~" +specials = "(),;[]`{}" +spaces = " \t\n" + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +showSDocForUser' :: GHC.GhcMonad m => SDoc -> m String +showSDocForUser' doc = do + dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession + name_ppr_ctx <- GHC.getNamePprCtx + pure $ showSDocForUser dflags unit_state name_ppr_ctx doc + +showSDocForUserQualify :: GHC.GhcMonad m => SDoc -> m String +showSDocForUserQualify doc = do + dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession + pure $ showSDocForUser dflags unit_state alwaysQualify doc + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) +keepGoing a str = keepGoing' (lift . a) str + +keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) +keepGoingMulti a str = keepGoingMulti' (lift . a) str + +keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome +keepGoing' a str = do + in_multi <- inMultiMode + if in_multi + then + liftIO $ hPutStrLn stderr "Command is not supported (yet) in multi-mode" + else + a str + return CmdSuccess + +-- For commands which are actually support in multi-mode, initially just :reload +keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome +keepGoingMulti' a str = a str >> return CmdSuccess + +inMultiMode :: GhciMonad m => m Bool +inMultiMode = multiMode <$> getGHCiState + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) +keepGoingPaths a str + = do case toArgsNoLoc str of + Left err -> liftIO $ hPutStrLn stderr err >> return CmdSuccess + Right args -> keepGoing' a args + +defShortHelpText :: String +defShortHelpText = "use :? for help.\n" + +defFullHelpText :: String +defFullHelpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :complete [] list completions for partial input string\n" ++ + " :def[!] define command : (later defined command has\n" ++ + " precedence, :: is always a builtin command)\n" ++ + " (!: redefine an existing command name)\n" ++ + " :doc display docs for the given name (experimental)\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :help, :? display this list of commands\n" ++ + " :info[!] [ ...] display information about the given names\n" ++ + " (!: do not filter instances)\n" ++ + " :instances display the class instances available for \n" ++ + " :issafe [] display safe haskell information of module \n" ++ + " :kind[!] show the kind of \n" ++ + " (!: also print the normalised type)\n" ++ + " :load[!] [*] ... load module(s) and their dependents\n" ++ + " (!: defer type errors)\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload[!] reload the current module set\n" ++ + " (!: defer type errors)\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script \n" ++ + " :type show the type of \n" ++ + " :type +d show the type of , defaulting type variables\n" ++ + " :unadd ... remove module(s) from the current target set\n" ++ + " :undef undefine user-defined command :\n" ++ + " :: run the builtin command\n" ++ + " :! run the shell command \n" ++ + "\n" ++ + " -- Commands for debugging:\n" ++ + "\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ + " :back [] go back in the history N steps (after :trace)\n" ++ + " :break [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue [] resume after a breakpoint [and set break ignore count]\n" ++ + " :delete ... delete the specified breakpoints\n" ++ + " :delete * delete all breakpoints\n" ++ + " :disable ... disable the specified breakpoints\n" ++ + " :disable * disable all breakpoints\n" ++ + " :enable ... enable the specified breakpoints\n" ++ + " :enable * enable all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward [] go forward in the history N step s(after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :ignore for break set break ignore \n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] show a value without forcing its computation\n" ++ + " :sprint [ ...] simplified version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \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 evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set