From fabb6bc0f72594225b549de7f15076f18cd9168e Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Sat, 20 Jul 2024 12:31:38 +0200 Subject: [PATCH 01/18] Build clash-prelude warning-free on GHC 9.10 (cherry picked from commit e702e9a7debff42705762eeb7771e764074f8aa3) --- cabal.project | 9 +- clash-ffi/clash-ffi.cabal | 2 +- clash-ghc/clash-ghc.cabal | 12 +- clash-lib/clash-lib.cabal | 4 +- clash-prelude/clash-prelude.cabal | 2 +- .../src/Clash/Class/BitPack/BitIndex.hs | 26 ++- .../src/Clash/Class/BitPack/Internal/TH.hs | 4 +- .../src/Clash/Explicit/BlockRam/Blob.hs | 199 ++++++++++-------- .../src/Clash/Explicit/BlockRam/Internal.hs | 5 +- .../src/Clash/Signal/Bundle/Internal.hs | 11 +- clash-prelude/src/Clash/Signal/Trace.hs | 7 +- .../src/Clash/Sized/Internal/BitVector.hs | 5 +- clash-prelude/src/Clash/Sized/RTree.hs | 27 ++- clash-prelude/src/Clash/Sized/Vector.hs | 103 ++++++++- 14 files changed, 295 insertions(+), 121 deletions(-) diff --git a/cabal.project b/cabal.project index d36b2b015d..36a2321f05 100644 --- a/cabal.project +++ b/cabal.project @@ -16,7 +16,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: 2024-07-06T09:03:11Z +index-state: 2024-07-18T12:39:16Z -- For some reason the `clash-testsuite` executable fails to run without -- this, as it cannot find the related library... @@ -72,7 +72,12 @@ allow-newer: rewrite-inspector:containers, vty:deepseq, derive-storable-plugin:ghc, - derive-storable-plugin:ghci + derive-storable-plugin:ghci, + string-random:text, + string-random:containers, + string-interpolate:template-haskell, + string-interpolate:text, + hint:ghc -- Works around: https://github.com/recursion-schemes/recursion-schemes/issues/128. This -- shouldn't harm (runtime) performance of Clash, as we only use recursion-schemes with diff --git a/clash-ffi/clash-ffi.cabal b/clash-ffi/clash-ffi.cabal index 36b194cb75..15b8c1e4e5 100644 --- a/clash-ffi/clash-ffi.cabal +++ b/clash-ffi/clash-ffi.cabal @@ -20,7 +20,7 @@ common common-options ghc-options: -Wall -Wcompat build-depends: - base >= 4.11 && < 4.20, + base >= 4.11 && < 4.21, bytestring >= 0.10 && < 0.13, clash-prelude >= 1.2 && < 1.10, deepseq >= 1.4 && < 1.6, diff --git a/clash-ghc/clash-ghc.cabal b/clash-ghc/clash-ghc.cabal index e4e7a77d68..b6ca13912e 100644 --- a/clash-ghc/clash-ghc.cabal +++ b/clash-ghc/clash-ghc.cabal @@ -176,26 +176,26 @@ library ghc-typelits-natnormalise >= 0.6 && < 0.8, deepseq >= 1.3.0.2 && < 1.6, time >= 1.4.0.1 && < 1.15, - ghc-boot >= 8.6.0 && < 9.9, + ghc-boot >= 8.6.0 && < 9.11, ghc-prim >= 0.3.1.0 && < 0.12, - ghci >= 8.6.0 && < 9.9, + ghci >= 8.6.0 && < 9.11, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0, primitive >= 0.5.0.1 && < 1.0, string-interpolate ^>= 0.3, - template-haskell >= 2.8.0.0 && < 2.22, + template-haskell >= 2.8.0.0 && < 2.23, utf8-string >= 1.0.0.0 && < 1.1.0.0, vector >= 0.11 && < 1.0 if os(windows) -- 8.8 is broken on Windows - it randomly segfaults - Build-Depends: ghc >= 8.6.0 && < 8.8.0 || >= 8.10.0 && < 9.9 + Build-Depends: ghc >= 8.6.0 && < 8.8.0 || >= 8.10.0 && < 9.11 elif os(darwin) -- 8.10 is broken on macOS - it exits tests with status code -11 - Build-Depends: ghc >= 8.6.0 && < 8.10.0 || >= 9.0.0 && < 9.9 + Build-Depends: ghc >= 8.6.0 && < 8.10.0 || >= 9.0.0 && < 9.11 else -- Unix - Build-Depends: ghc >= 8.6.0 && < 9.9 + Build-Depends: ghc >= 8.6.0 && < 9.11 if impl(ghc >= 8.10.0) Build-Depends: exceptions >= 0.10.4 && < 0.11, diff --git a/clash-lib/clash-lib.cabal b/clash-lib/clash-lib.cabal index 833f68f260..5d1ba01f8f 100644 --- a/clash-lib/clash-lib.cabal +++ b/clash-lib/clash-lib.cabal @@ -163,7 +163,7 @@ Library exceptions >= 0.8.3 && < 0.11.0, extra >= 1.6.17 && < 1.8, filepath >= 1.3.0.1 && < 1.6, - ghc >= 8.6.0 && < 9.9, + ghc >= 8.6.0 && < 9.11, ghc-boot-th, ghc-prim, hashable >= 1.2.1.0 && < 1.6, @@ -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.22, + template-haskell >= 2.8.0.0 && < 2.23, temporary >= 1.2.1 && < 1.4, terminal-size >= 0.3 && < 0.4, text >= 1.2.2 && < 2.2, diff --git a/clash-prelude/clash-prelude.cabal b/clash-prelude/clash-prelude.cabal index 7c03b99c63..657e16abb2 100644 --- a/clash-prelude/clash-prelude.cabal +++ b/clash-prelude/clash-prelude.cabal @@ -357,7 +357,7 @@ Library singletons >= 2.0 && < 3.1, string-interpolate ^>= 0.3, tagged >= 0.8 && < 0.9, - template-haskell >= 2.12.0.0 && < 2.22, + template-haskell >= 2.12.0.0 && < 2.23, 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/Class/BitPack/BitIndex.hs b/clash-prelude/src/Clash/Class/BitPack/BitIndex.hs index 3d6a706aba..def3032385 100644 --- a/clash-prelude/src/Clash/Class/BitPack/BitIndex.hs +++ b/clash-prelude/src/Clash/Class/BitPack/BitIndex.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2013-2016, University of Twente - 2021, QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -54,7 +54,17 @@ __NB__: Bit indices are __DESCENDING__. >>> slice d4 d2 (7 :: Unsigned 6) 0b001 -#if __GLASGOW_HASKELL__ == 906 +#if __GLASGOW_HASKELL__ >= 910 +>>> slice d6 d4 (7 :: Unsigned 6) +:... + • Couldn't match type ‘7 + i0’ with ‘6’ + arising from a use of ‘slice’ + The type variable ‘i0’ is ambiguous + • In the expression: slice d6 d4 (7 :: Unsigned 6) + In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6) + + +#elif __GLASGOW_HASKELL__ == 906 >>> slice d6 d4 (7 :: Unsigned 6) :... @@ -131,7 +141,17 @@ __NB__: Bit indices are __DESCENDING__. >>> pack (-29 :: Signed 6) 0b10_0011 -#if __GLASGOW_HASKELL__ == 906 +#if __GLASGOW_HASKELL__ >= 910 +>>> setSlice d6 d5 0 (-5 :: Signed 6) +:... + • Couldn't match type ‘7 + i0’ with ‘6’ + arising from a use of ‘setSlice’ + The type variable ‘i0’ is ambiguous + • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6) + In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6) + + +#elif __GLASGOW_HASKELL__ == 906 >>> setSlice d6 d5 0 (-5 :: Signed 6) :... diff --git a/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs b/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs index 7fb101bbd2..d5817d763f 100644 --- a/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs +++ b/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs @@ -1,5 +1,5 @@ {-| -Copyright : (C) 2019, QBayLogic B.V. +Copyright : (C) 2019-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -11,7 +11,9 @@ module Clash.Class.BitPack.Internal.TH where import Clash.CPP (maxTupleSize) import Language.Haskell.TH.Compat (mkTySynInstD,mkTupE) import Control.Monad (replicateM) +#if !MIN_VERSION_base(4,20,0) import Data.List (foldl') +#endif import GHC.TypeLits (KnownNat) import Language.Haskell.TH diff --git a/clash-prelude/src/Clash/Explicit/BlockRam/Blob.hs b/clash-prelude/src/Clash/Explicit/BlockRam/Blob.hs index 73b70f1271..7f01137dd2 100644 --- a/clash-prelude/src/Clash/Explicit/BlockRam/Blob.hs +++ b/clash-prelude/src/Clash/Explicit/BlockRam/Blob.hs @@ -1,5 +1,5 @@ {-| -Copyright : (C) 2021-2022, QBayLogic B.V. +Copyright : (C) 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -236,55 +236,68 @@ blockRamBlob# !_ gen content@MemBlob{} = \rd wen waS wd -> runST $ do -- See: https://github.com/clash-lang/clash-compiler/pull/2511 {-# CLASH_OPAQUE blockRamBlob# #-} --- | Create a 'MemBlob' binding from a list of values --- --- Since this uses Template Haskell, nothing in the arguments given to --- 'createMemBlob' can refer to something defined in the same module. --- --- === __Example__ --- --- @ --- 'createMemBlob' "content" 'Nothing' [15 :: Unsigned 8 .. 17] --- --- ram clk en = 'blockRamBlob' clk en content --- @ --- --- The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value --- does not matter. But the bits need a defined value in the memory. Either 0 or --- 1 can be used, and both are valid representations of the data. --- --- >>> import qualified Prelude as P --- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ] --- >>> :{ --- createMemBlob "content0" (Just 0) es --- createMemBlob "content1" (Just 1) es --- x = 1 --- :} --- --- >>> let pr = mapM_ (putStrLn . show) --- >>> pr $ P.map pack es --- 0b0_...._.... --- 0b1_0000_0111 --- 0b1_0000_1000 --- >>> pr $ unpackMemBlob content0 --- 0b0_0000_0000 --- 0b1_0000_0111 --- 0b1_0000_1000 --- >>> pr $ unpackMemBlob content1 --- 0b0_1111_1111 --- 0b1_0000_0111 --- 0b1_0000_1000 --- >>> :{ --- createMemBlob "contentN" Nothing es --- x = 1 --- :} --- --- :...: error:... --- packBVs: cannot convert don't care values. Please specify a mapping to a definite value. --- --- Note how we hinted to @clashi@ that our multi-line command was a list of --- declarations by including a dummy declaration @x = 1@. Without this trick, --- @clashi@ would expect an expression and the Template Haskell would not work. +{- | Create a 'MemBlob' binding from a list of values + +Since this uses Template Haskell, nothing in the arguments given to +'createMemBlob' can refer to something defined in the same module. + +=== __Example__ + +@ +'createMemBlob' "content" 'Nothing' [15 :: Unsigned 8 .. 17] + +ram clk en = 'blockRamBlob' clk en content +@ + +The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value +does not matter. But the bits need a defined value in the memory. Either 0 or +1 can be used, and both are valid representations of the data. + +>>> import qualified Prelude as P +>>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ] +>>> :{ +createMemBlob "content0" (Just 0) es +createMemBlob "content1" (Just 1) es +x = 1 +:} + +>>> let pr = mapM_ (putStrLn . show) +>>> pr $ P.map pack es +0b0_...._.... +0b1_0000_0111 +0b1_0000_1000 +>>> pr $ unpackMemBlob content0 +0b0_0000_0000 +0b1_0000_0111 +0b1_0000_1000 +>>> pr $ unpackMemBlob content1 +0b0_1111_1111 +0b1_0000_0111 +0b1_0000_1000 + +#if __GLASGOW_HASKELL__ >= 910 +>>> :{ +createMemBlob "contentN" Nothing es +x = 1 +:} +:...: error:... + packBVs: cannot convert don't care values. Please specify a mapping to a definite value. + + +#else +>>> :{ +createMemBlob "contentN" Nothing es +x = 1 +:} + +:...: error:... + packBVs: cannot convert don't care values. Please specify a mapping to a definite value. + +#endif +Note how we hinted to @clashi@ that our multi-line command was a list of +declarations by including a dummy declaration @x = 1@. Without this trick, +@clashi@ would expect an expression and the Template Haskell would not work. +-} createMemBlob :: forall a f . ( Foldable f @@ -320,43 +333,55 @@ createMemBlob name care es = (len, runsB, endsB) = either error id packed packed = packBVs care es --- | Create a 'MemBlob' from a list of values --- --- Since this uses Template Haskell, nothing in the arguments given to --- 'memBlobTH' can refer to something defined in the same module. --- --- === __Example__ --- --- @ --- ram clk en = 'blockRamBlob' clk en $(memBlobTH Nothing [15 :: Unsigned 8 .. 17]) --- @ --- --- The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value --- does not matter. But the bits need a defined value in the memory. Either 0 or --- 1 can be used, and both are valid representations of the data. --- --- >>> import qualified Prelude as P --- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ] --- >>> content0 = $(memBlobTH (Just 0) es) --- >>> content1 = $(memBlobTH (Just 1) es) --- >>> let pr = mapM_ (putStrLn . show) --- >>> pr $ P.map pack es --- 0b0_...._.... --- 0b1_0000_0111 --- 0b1_0000_1000 --- >>> pr $ unpackMemBlob content0 --- 0b0_0000_0000 --- 0b1_0000_0111 --- 0b1_0000_1000 --- >>> pr $ unpackMemBlob content1 --- 0b0_1111_1111 --- 0b1_0000_0111 --- 0b1_0000_1000 --- >>> $(memBlobTH Nothing es) --- --- :...: error:... --- • packBVs: cannot convert don't care values. Please specify a mapping to a definite value. --- • In the untyped splice: $(memBlobTH Nothing es) +{- | Create a 'MemBlob' from a list of values + +Since this uses Template Haskell, nothing in the arguments given to +'memBlobTH' can refer to something defined in the same module. + +=== __Example__ + +@ +ram clk en = 'blockRamBlob' clk en $(memBlobTH Nothing [15 :: Unsigned 8 .. 17]) +@ + +The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value +does not matter. But the bits need a defined value in the memory. Either 0 or +1 can be used, and both are valid representations of the data. + +>>> import qualified Prelude as P +>>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ] +>>> content0 = $(memBlobTH (Just 0) es) +>>> content1 = $(memBlobTH (Just 1) es) +>>> let pr = mapM_ (putStrLn . show) +>>> pr $ P.map pack es +0b0_...._.... +0b1_0000_0111 +0b1_0000_1000 +>>> pr $ unpackMemBlob content0 +0b0_0000_0000 +0b1_0000_0111 +0b1_0000_1000 +>>> pr $ unpackMemBlob content1 +0b0_1111_1111 +0b1_0000_0111 +0b1_0000_1000 + +#if __GLASGOW_HASKELL__ >= 910 +>>> $(memBlobTH Nothing es) +:...: error:... + • packBVs: cannot convert don't care values. Please specify a mapping to a definite value. + • In the untyped splice: $(memBlobTH Nothing es) + + +#else +>>> $(memBlobTH Nothing es) + +:...: error:... + • packBVs: cannot convert don't care values. Please specify a mapping to a definite value. + • In the untyped splice: $(memBlobTH Nothing es) + +#endif +-} memBlobTH :: forall a f . ( Foldable f diff --git a/clash-prelude/src/Clash/Explicit/BlockRam/Internal.hs b/clash-prelude/src/Clash/Explicit/BlockRam/Internal.hs index 79870c8f33..a81d681099 100644 --- a/clash-prelude/src/Clash/Explicit/BlockRam/Internal.hs +++ b/clash-prelude/src/Clash/Explicit/BlockRam/Internal.hs @@ -1,9 +1,10 @@ {-| -Copyright : (C) 2021-2022, QBayLogic B.V. +Copyright : (C) 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Trustworthy #-} @@ -17,7 +18,9 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder (Builder, toLazyByteString, word8, word64BE) import qualified Data.ByteString.Unsafe as B +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import Data.Word (Word64) import GHC.Exts (Addr#) import GHC.TypeLits (KnownNat, Nat) diff --git a/clash-prelude/src/Clash/Signal/Bundle/Internal.hs b/clash-prelude/src/Clash/Signal/Bundle/Internal.hs index 9f368ce0ba..35a80e8615 100644 --- a/clash-prelude/src/Clash/Signal/Bundle/Internal.hs +++ b/clash-prelude/src/Clash/Signal/Bundle/Internal.hs @@ -1,3 +1,9 @@ +{-| +Copyright : (C) 2024, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +-} + {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} @@ -9,7 +15,10 @@ import Clash.Annotations.Primitive (Primitive(InlineYamlPrimitive)) import Clash.CPP (maxTupleSize) import Clash.Signal.Internal (Signal((:-))) import Clash.XException (seqX) -import Data.List (foldl', uncons) +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif +import Data.List (uncons) import Data.String.Interpolate (__i) import qualified Language.Haskell.TH.Syntax as TH import Language.Haskell.TH diff --git a/clash-prelude/src/Clash/Signal/Trace.hs b/clash-prelude/src/Clash/Signal/Trace.hs index 8587986dff..db4b23a5c1 100644 --- a/clash-prelude/src/Clash/Signal/Trace.hs +++ b/clash-prelude/src/Clash/Signal/Trace.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2018, Google Inc. 2019, Myrtle Software Ltd - 2022, QBayLogic B.V. + 2022-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -111,7 +111,10 @@ import qualified Data.ByteString.Lazy as ByteStringLazy import Data.Char (ord, chr) import Data.IORef (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef) -import Data.List (foldl1', foldl', unzip4, transpose, uncons) +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif +import Data.List (foldl1', unzip4, transpose, uncons) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, catMaybes) import qualified Data.Text as Text diff --git a/clash-prelude/src/Clash/Sized/Internal/BitVector.hs b/clash-prelude/src/Clash/Sized/Internal/BitVector.hs index 94e15e9fed..430faca10a 100644 --- a/clash-prelude/src/Clash/Sized/Internal/BitVector.hs +++ b/clash-prelude/src/Clash/Sized/Internal/BitVector.hs @@ -150,20 +150,19 @@ import Numeric (readOct, readHex) import GHC.Exts (Word#, Word (W#), eqWord#, int2Word#, isTrue#, uncheckedShiftRL#) #if MIN_VERSION_base(4,15,0) -import GHC.Exts (minusWord#, gtWord#, word2Int#) +import GHC.Exts (minusWord#, gtWord#, word2Int#, dataToTag#) import GHC.Num.BigNat (bigNatShiftR#, bigNatToWord) import GHC.Num.Integer (integerFromNatural, integerToNatural) import GHC.Num.Natural (Natural (..), naturalFromWord, naturalShiftL, naturalShiftR, naturalToWord) #else -import GHC.Exts ((>#)) +import GHC.Exts ((>#), dataToTag#) import qualified GHC.Exts import GHC.Integer.GMP.Internals (Integer (..), bigNatToWord, shiftRBigNat) import GHC.Natural (Natural (..), naturalFromInteger, wordToNatural) #endif import GHC.Natural (naturalToInteger) -import GHC.Prim (dataToTag#) import GHC.Stack (withFrozenCallStack) import GHC.TypeLits (KnownNat, Nat, type (+), type (-)) #if MIN_VERSION_base(4,15,0) diff --git a/clash-prelude/src/Clash/Sized/RTree.hs b/clash-prelude/src/Clash/Sized/RTree.hs index bf698cb962..61845302fd 100644 --- a/clash-prelude/src/Clash/Sized/RTree.hs +++ b/clash-prelude/src/Clash/Sized/RTree.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2016, University of Twente - 2022, QBayLogic B.V. + 2022-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -299,7 +299,30 @@ defined in the instance 'Clash.Class.Num.ExtendingNum' instance of 'Index'. However, we cannot simply use 'Clash.Sized.Vector.fold' to create a tree-structure of 'Clash.Class.Num.add's: -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 910 +>>> :{ +let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1)) + => BitVector (2^d) -> Index (2^d+1) + populationCount' = tfold (resize . bv2i . pack) add . v2t . bv2v +:} +:... + • Couldn't match type: (((2 ^ d) + 1) + ((2 ^ d) + 1)) - 1 + with: (2 ^ d) + 1 + Expected: Index ((2 ^ d) + 1) + -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1) + Actual: Index ((2 ^ d) + 1) + -> Index ((2 ^ d) + 1) + -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1)) + • In the second argument of ‘tfold’, namely ‘add’ + In the first argument of ‘(.)’, namely + ‘tfold (resize . bv2i . pack) add’ + In the expression: tfold (resize . bv2i . pack) add . v2t . bv2v + • Relevant bindings include + populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1) + (bound at ...) + + +#elif __GLASGOW_HASKELL__ >= 900 >>> :{ let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1)) => BitVector (2^d) -> Index (2^d+1) diff --git a/clash-prelude/src/Clash/Sized/Vector.hs b/clash-prelude/src/Clash/Sized/Vector.hs index 1863f8f7bf..0afab8217b 100644 --- a/clash-prelude/src/Clash/Sized/Vector.hs +++ b/clash-prelude/src/Clash/Sized/Vector.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2017 , Myrtle Software Ltd - 2022-2023, QBayLogic B.V. + 2022-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -408,7 +408,18 @@ singleton = (`Cons` Nil) >>> head (1:>2:>3:>Nil) 1 -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 910 +>>> head Nil +:... + • Couldn't match type ‘1’ with ‘0’ + Expected: Vec (0 + 1) a + Actual: Vec 0 a + • In the first argument of ‘head’, namely ‘Nil’ + In the expression: head Nil + In an equation for ‘it’: it = head Nil + + +#elif __GLASGOW_HASKELL__ >= 900 >>> head Nil :... @@ -443,7 +454,18 @@ head (x `Cons` _) = x >>> tail (1:>2:>3:>Nil) 2 :> 3 :> Nil -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 910 +>>> tail Nil +:... + • Couldn't match type ‘1’ with ‘0’ + Expected: Vec (0 + 1) a + Actual: Vec 0 a + • In the first argument of ‘tail’, namely ‘Nil’ + In the expression: tail Nil + In an equation for ‘it’: it = tail Nil + + +#elif __GLASGOW_HASKELL__ >= 900 >>> tail Nil :... @@ -478,7 +500,18 @@ tail (_ `Cons` xs) = xs >>> last (1:>2:>3:>Nil) 3 -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 910 +>>> last Nil +:... + • Couldn't match type ‘1’ with ‘0’ + Expected: Vec (0 + 1) a + Actual: Vec 0 a + • In the first argument of ‘last’, namely ‘Nil’ + In the expression: last Nil + In an equation for ‘it’: it = last Nil + + +#elif __GLASGOW_HASKELL__ >= 900 >>> last Nil :... @@ -514,7 +547,18 @@ last (_ `Cons` y `Cons` ys) = last (y `Cons` ys) >>> init (1:>2:>3:>Nil) 1 :> 2 :> Nil -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 910 +>>> init Nil +:... + • Couldn't match type ‘1’ with ‘0’ + Expected: Vec (0 + 1) a + Actual: Vec 0 a + • In the first argument of ‘init’, namely ‘Nil’ + In the expression: init Nil + In an equation for ‘it’: it = init Nil + + +#elif __GLASGOW_HASKELL__ >= 900 >>> init Nil :... @@ -809,7 +853,7 @@ imap f = go 0 {- | Zip two vectors with a functions that also takes the elements' indices. -#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 904 +#if (__GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 904) || __GLASGOW_HASKELL__ >= 910 >>> izipWith (\i a b -> i + a + b) (2 :> 2 :> Nil) (3 :> 3:> Nil) *** Exception: X: Clash.Sized.Index: result 2 is out of bounds: [0..1] ... @@ -1490,7 +1534,19 @@ replace i y xs = replace_int xs (fromEnum i) y >>> take d0 (1:>2:>Nil) Nil -#if __GLASGOW_HASKELL__ == 906 +#if __GLASGOW_HASKELL__ >= 910 +>>> take d4 (1:>2:>Nil) +:... + • Couldn't match type ‘4 + n0’ with ‘2’ + Expected: Vec (4 + n0) a + Actual: Vec (1 + 1) a + The type variable ‘n0’ is ambiguous + • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’ + In the expression: take d4 (1 :> 2 :> Nil) + In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil) + + +#elif __GLASGOW_HASKELL__ == 906 >>> take d4 (1:>2:>Nil) :... @@ -1549,7 +1605,16 @@ takeI = withSNat take >>> drop d0 (1:>2:>Nil) 1 :> 2 :> Nil -#if __GLASGOW_HASKELL__ == 906 +#if __GLASGOW_HASKELL__ >= 910 +>>> drop d4 (1:>2:>Nil) +:...: error:... + • Couldn't match...type ‘4 + n0... + The type variable ‘n0’ is ambiguous + • In the first argument of ‘print’, namely ‘it’ + In a stmt of an interactive GHCi command: print it + + +#elif __GLASGOW_HASKELL__ == 906 >>> drop d4 (1:>2:>Nil) :...: error:... @@ -2364,7 +2429,27 @@ defined in the instance 'Clash.Class.Num.ExtendingNum' instance of 'Index'. However, we cannot simply use 'fold' to create a tree-structure of 'Clash.Class.Num.add'es: -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 910 +>>> :{ +let populationCount' :: (KnownNat (n+1), KnownNat (n+2)) + => BitVector (n+1) -> Index (n+2) + populationCount' = fold add . map fromIntegral . bv2v +:} +:... + • Couldn't match type: ((n + 2) + (n + 2)) - 1 + with: n + 2 + Expected: Index (n + 2) -> Index (n + 2) -> Index (n + 2) + Actual: Index (n + 2) + -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2)) + • In the first argument of ‘fold’, namely ‘add’ + In the first argument of ‘(.)’, namely ‘fold add’ + In the expression: fold add . map fromIntegral . bv2v + • Relevant bindings include + populationCount' :: BitVector (n + 1) -> Index (n + 2) + (bound at ...) + + +#elif __GLASGOW_HASKELL__ >= 900 >>> :{ let populationCount' :: (KnownNat (n+1), KnownNat (n+2)) => BitVector (n+1) -> Index (n+2) From a41359fb29cae1eb53872e4c72536ce7f4d3912e Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Sun, 21 Jul 2024 07:25:49 +0200 Subject: [PATCH 02/18] Build clash-lib warning-free on GHC 9.10 This also introduces a new functions, fromGhcUnique, which converts from GHC's Unique to Clash's Unique. This function is used wherever we interact with Uniques we get from GHC. (cherry picked from commit 1f8e7658b0c50ac682b425b4b4d7b8ef8c80d722) --- clash-lib/src/Clash/Backend/Verilog.hs | 5 +- clash-lib/src/Clash/Core/EqSolver.hs | 6 +- clash-lib/src/Clash/Core/Evaluator/Types.hs | 4 +- clash-lib/src/Clash/Core/Term.hs | 4 +- clash-lib/src/Clash/Core/TyCon.hs | 2 +- clash-lib/src/Clash/Core/Type.hs | 60 ++++++++------- clash-lib/src/Clash/Core/TysPrim.hs | 73 +++++++++++-------- clash-lib/src/Clash/Core/Util.hs | 7 +- clash-lib/src/Clash/Driver.hs | 10 +-- .../Clash/Normalize/PrimitiveReductions.hs | 20 +++-- .../Clash/Normalize/Transformations/Case.hs | 2 +- clash-lib/src/Clash/Normalize/Util.hs | 8 +- clash-lib/src/Clash/Unique.hs | 27 +++++++ clash-lib/src/Data/Aeson/Extra.hs | 6 ++ 14 files changed, 146 insertions(+), 88 deletions(-) diff --git a/clash-lib/src/Clash/Backend/Verilog.hs b/clash-lib/src/Clash/Backend/Verilog.hs index f88a3517bb..1dd81118db 100644 --- a/clash-lib/src/Clash/Backend/Verilog.hs +++ b/clash-lib/src/Clash/Backend/Verilog.hs @@ -49,7 +49,10 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Ap(Ap)) import Data.Monoid.Extra () import Data.List - (mapAccumL, mapAccumR, nubBy, foldl') + (mapAccumL, mapAccumR, nubBy) +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif import Data.List.Extra ((<:>)) import Data.Text.Lazy (pack) import qualified Data.Text.Lazy as Text diff --git a/clash-lib/src/Clash/Core/EqSolver.hs b/clash-lib/src/Clash/Core/EqSolver.hs index b79d37c65b..9e718e2fb1 100644 --- a/clash-lib/src/Clash/Core/EqSolver.hs +++ b/clash-lib/src/Clash/Core/EqSolver.hs @@ -1,5 +1,5 @@ {-| - Copyright : (C) 2021 QBayLogic B.V. + Copyright : (C) 2021-2024 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -20,8 +20,8 @@ import Clash.Core.Var import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet) #if MIN_VERSION_ghc(9,0,0) import Clash.Core.DataCon (dcUniq) +import Clash.Unique (fromGhcUnique) import GHC.Builtin.Names (unsafeReflDataConKey) -import GHC.Types.Unique (getKey) #endif -- | Data type that indicates what kind of solution (if any) was found @@ -139,7 +139,7 @@ isAbsurdPat #if MIN_VERSION_base(4,15,0) isAbsurdPat _tcm (DataPat dc _ _) -- unsafeCoerce is not absurd in the way intended by /isAbsurdPat/ - | dcUniq dc == getKey unsafeReflDataConKey + | dcUniq dc == fromGhcUnique unsafeReflDataConKey = False #endif isAbsurdPat tcm pat = diff --git a/clash-lib/src/Clash/Core/Evaluator/Types.hs b/clash-lib/src/Clash/Core/Evaluator/Types.hs index 831a636d8e..112cf82e79 100644 --- a/clash-lib/src/Clash/Core/Evaluator/Types.hs +++ b/clash-lib/src/Clash/Core/Evaluator/Types.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| - Copyright : (C) 2020-2022, QBayLogic B.V. + Copyright : (C) 2020-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -14,7 +14,9 @@ module Clash.Core.Evaluator.Types where import Control.Concurrent.Supply (Supply) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap (insert, lookup) +#if !MIN_VERSION_base(4,20,0) import Data.List (foldl') +#endif import Data.Maybe (fromMaybe, isJust) #if MIN_VERSION_prettyprinter(1,7,0) diff --git a/clash-lib/src/Clash/Core/Term.hs b/clash-lib/src/Clash/Core/Term.hs index 614fe5faf5..5e6731a9b5 100644 --- a/clash-lib/src/Clash/Core/Term.hs +++ b/clash-lib/src/Clash/Core/Term.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc. - 2021, QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -63,7 +63,9 @@ import Data.Binary (Binary) import Data.Coerce (coerce) import qualified Data.DList as DList import Data.Either (lefts, rights) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import Data.Hashable (Hashable) import Data.Maybe (catMaybes) import Data.List (nub, partition) diff --git a/clash-lib/src/Clash/Core/TyCon.hs b/clash-lib/src/Clash/Core/TyCon.hs index 0ffc0a421d..b6ae080a44 100644 --- a/clash-lib/src/Clash/Core/TyCon.hs +++ b/clash-lib/src/Clash/Core/TyCon.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente - 2021, QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. diff --git a/clash-lib/src/Clash/Core/Type.hs b/clash-lib/src/Clash/Core/Type.hs index 958c057b7f..3af9b55daa 100644 --- a/clash-lib/src/Clash/Core/Type.hs +++ b/clash-lib/src/Clash/Core/Type.hs @@ -62,7 +62,9 @@ import Control.DeepSeq as DS import Data.Binary (Binary) import Data.Coerce (coerce) import Data.Hashable (Hashable (hashWithSalt)) +#if !MIN_VERSION_base(4,20,0) import Data.List (foldl') +#endif import Data.List.Extra (splitAtList) import Data.Maybe (isJust, mapMaybe) import Data.Text (Text) @@ -93,7 +95,6 @@ import GHC.Builtin.Names typeNatCmpTyFamNameKey, ordLTDataConKey, ordEQDataConKey, ordGTDataConKey, typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey) import GHC.Types.SrcLoc (wiredInSrcSpan) -import GHC.Types.Unique (getKey) #else #if __GLASGOW_HASKELL__ >= 808 import PrelNames @@ -109,7 +110,6 @@ import PrelNames typeNatCmpTyFamNameKey, typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey) import SrcLoc (wiredInSrcSpan) -import Unique (getKey) #endif -- Local imports @@ -120,6 +120,7 @@ import {-# SOURCE #-} Clash.Core.Subst import Clash.Core.TyCon import Clash.Core.Var import qualified Clash.Data.UniqMap as UniqMap +import Clash.Unique (fromGhcUnique) import Clash.Util #if __GLASGOW_HASKELL__ <= 806 @@ -519,22 +520,22 @@ type families do not reduce on stuck argument, we assume strictly. reduceTypeFamily :: TyConMap -> Type -> Maybe Type reduceTypeFamily tcm (tyView -> TyConApp tc tys) - | nameUniq tc == getKey typeNatAddTyFamNameKey + | nameUniq tc == fromGhcUnique typeNatAddTyFamNameKey = case mapMaybe (litView tcm) tys of [i1,i2] -> Just (LitTy (NumTy (i1 + i2))) _ -> Nothing - | nameUniq tc == getKey typeNatMulTyFamNameKey + | nameUniq tc == fromGhcUnique typeNatMulTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 * i2))) _ -> Nothing - | nameUniq tc == getKey typeNatExpTyFamNameKey + | nameUniq tc == fromGhcUnique typeNatExpTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 ^ i2))) _ -> Nothing - | nameUniq tc == getKey typeNatSubTyFamNameKey + | nameUniq tc == fromGhcUnique typeNatSubTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] | let z = i1 - i2 @@ -543,7 +544,7 @@ reduceTypeFamily tcm (tyView -> TyConApp tc tys) _ -> Nothing #if !MIN_VERSION_ghc(9,2,0) - | nameUniq tc == getKey typeNatLeqTyFamNameKey + | nameUniq tc == fromGhcUnique typeNatLeqTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] | Just (FunTyCon {tyConKind = tck}) <- UniqMap.lookup tc tcm @@ -555,44 +556,53 @@ reduceTypeFamily tcm (tyView -> TyConApp tc tys) _ -> Nothing #endif - | nameUniq tc == getKey typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat" + | nameUniq tc == fromGhcUnique typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat" = case mapMaybe (litView tcm) tys of [i1, i2] -> Just $ ConstTy $ TyCon $ case compare i1 i2 of - LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan - EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan - GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan + LT -> Name User "GHC.Types.LT" + (fromGhcUnique ordLTDataConKey) wiredInSrcSpan + EQ -> Name User "GHC.Types.EQ" + (fromGhcUnique ordEQDataConKey) wiredInSrcSpan + GT -> Name User "GHC.Types.GT" + (fromGhcUnique ordGTDataConKey) wiredInSrcSpan _ -> Nothing - | nameUniq tc == getKey typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" + | nameUniq tc == fromGhcUnique typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" = case mapMaybe (symLitView tcm) tys of [s1, s2] -> Just $ ConstTy $ TyCon $ case compare s1 s2 of - LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan - EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan - GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan + LT -> Name User "GHC.Types.LT" + (fromGhcUnique ordLTDataConKey) wiredInSrcSpan + EQ -> Name User "GHC.Types.EQ" + (fromGhcUnique ordEQDataConKey) wiredInSrcSpan + GT -> Name User "GHC.Types.GT" + (fromGhcUnique ordGTDataConKey) wiredInSrcSpan _ -> Nothing #if MIN_VERSION_base(4,16,0) - | nameUniq tc == getKey typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" + | nameUniq tc == fromGhcUnique typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" = case mapMaybe (charLitView tcm) tys of [s1, s2] -> Just $ ConstTy $ TyCon $ case compare s1 s2 of - LT -> Name User (showt 'LT) (getKey ordLTDataConKey) wiredInSrcSpan - EQ -> Name User (showt 'EQ) (getKey ordEQDataConKey) wiredInSrcSpan - GT -> Name User (showt 'GT) (getKey ordGTDataConKey) wiredInSrcSpan + LT -> Name User (showt 'LT) + (fromGhcUnique ordLTDataConKey) wiredInSrcSpan + EQ -> Name User (showt 'EQ) + (fromGhcUnique ordEQDataConKey) wiredInSrcSpan + GT -> Name User (showt 'GT) + (fromGhcUnique ordGTDataConKey) wiredInSrcSpan _ -> Nothing - | nameUniq tc == getKey typeConsSymbolTyFamNameKey -- ConsSymbol + | nameUniq tc == fromGhcUnique typeConsSymbolTyFamNameKey -- ConsSymbol , [c0, s0] <- tys , Just c1 <- charLitView tcm c0 , Just s1 <- symLitView tcm s0 = Just (LitTy (SymTy (c1:s1))) - | nameUniq tc == getKey typeUnconsSymbolTyFamNameKey -- UnconsSymbol + | nameUniq tc == fromGhcUnique typeUnconsSymbolTyFamNameKey -- UnconsSymbol , [s1] <- mapMaybe (symLitView tcm) tys = fromMaybe (error "reduceTypeFamily: cannot construct UnconsSymbol result") $ do FunTyCon {tyConKind = tck} <- UniqMap.lookup tc tcm @@ -610,16 +620,16 @@ reduceTypeFamily tcm (tyView -> TyConApp tc tys) [charTy,symbolTy,LitTy (CharTy c),LitTy (SymTy cs)] in pure (Just (mkTyConApp justTc [tupTcApp,tup])) - | nameUniq tc == getKey typeCharToNatTyFamNameKey -- CharToNat + | nameUniq tc == fromGhcUnique typeCharToNatTyFamNameKey -- CharToNat , [c1] <- mapMaybe (charLitView tcm) tys = Just (LitTy (NumTy (fromIntegral (ord c1)))) - | nameUniq tc == getKey typeNatToCharTyFamNameKey -- NatToChar + | nameUniq tc == fromGhcUnique typeNatToCharTyFamNameKey -- NatToChar , [n1] <- mapMaybe (litView tcm) tys = Just (LitTy (CharTy (chr (fromInteger n1)))) #endif - | nameUniq tc == getKey typeSymbolAppendFamNameKey -- GHC.TypeLits.AppendSymbol" + | nameUniq tc == fromGhcUnique typeSymbolAppendFamNameKey -- GHC.TypeLits.AppendSymbol" = case mapMaybe (symLitView tcm) tys of [s1, s2] -> Just (LitTy (SymTy (s1 ++ s2))) @@ -716,7 +726,7 @@ charLitView _ _ = Nothing #endif isIntegerTy :: Type -> Bool -isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == getKey integerTyConKey +isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == fromGhcUnique integerTyConKey isIntegerTy _ = False -- | Normalize a type, looking through Signals and newtypes diff --git a/clash-lib/src/Clash/Core/TysPrim.hs b/clash-lib/src/Clash/Core/TysPrim.hs index a51992fa63..d57d275a3b 100644 --- a/clash-lib/src/Clash/Core/TysPrim.hs +++ b/clash-lib/src/Clash/Core/TysPrim.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, - 2021 , QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -47,10 +47,8 @@ where #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names -import GHC.Types.Unique (getKey) #else import PrelNames -import Unique (getKey) #endif #if MIN_VERSION_ghc(8,8,0) @@ -68,17 +66,21 @@ import Clash.Core.Name import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var (mkTyVar) +import Clash.Unique (fromGhcUnique) import qualified Clash.Data.UniqMap as UniqMap -- | Builtin Name liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName -liftedTypeKindTyConName = mkUnsafeSystemName "Type" (getKey liftedTypeKindTyConKey) +liftedTypeKindTyConName = mkUnsafeSystemName "Type" + (fromGhcUnique liftedTypeKindTyConKey) #if MIN_VERSION_ghc(9,2,0) typeNatKindTyConName = naturalPrimTyConName #else -typeNatKindTyConName = mkUnsafeSystemName "Nat" (getKey typeNatKindConNameKey) +typeNatKindTyConName = mkUnsafeSystemName "Nat" + (fromGhcUnique typeNatKindConNameKey) #endif -typeSymbolKindTyConName = mkUnsafeSystemName "Symbol" (getKey typeSymbolKindConNameKey) +typeSymbolKindTyConName = mkUnsafeSystemName "Symbol" + (fromGhcUnique typeSymbolKindConNameKey) -- | Builtin Kind liftedTypeKindTc, typeNatKindTc, typeSymbolKindTc :: TyCon @@ -96,53 +98,60 @@ intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName, floatPrimTyConName, doublePrimTyConName, naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName intPrimTyConName = mkUnsafeSystemName "GHC.Prim.Int#" - (getKey intPrimTyConKey) + (fromGhcUnique intPrimTyConKey) #if MIN_VERSION_base(4,15,0) integerPrimTyConName = mkUnsafeSystemName "GHC.Num.Integer.Integer" - (getKey integerTyConKey) + (fromGhcUnique integerTyConKey) #else integerPrimTyConName = mkUnsafeSystemName "GHC.Integer.Type.Integer" - (getKey integerTyConKey) + (fromGhcUnique integerTyConKey) #endif -stringPrimTyConName = mkUnsafeSystemName "GHC.Prim.Addr#" (getKey addrPrimTyConKey) +stringPrimTyConName = mkUnsafeSystemName "GHC.Prim.Addr#" + (fromGhcUnique addrPrimTyConKey) charPrimTyConName = mkUnsafeSystemName "GHC.Prim.Char#" - (getKey charPrimTyConKey) + (fromGhcUnique charPrimTyConKey) wordPrimTyConName = mkUnsafeSystemName "GHC.Prim.Word#" - (getKey wordPrimTyConKey) + (fromGhcUnique wordPrimTyConKey) int64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Int64#" - (getKey int64PrimTyConKey) + (fromGhcUnique int64PrimTyConKey) word64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Word64#" - (getKey word64PrimTyConKey) + (fromGhcUnique word64PrimTyConKey) floatPrimTyConName = mkUnsafeSystemName "GHC.Prim.Float#" - (getKey floatPrimTyConKey) + (fromGhcUnique floatPrimTyConKey) doublePrimTyConName = mkUnsafeSystemName "GHC.Prim.Double#" - (getKey doublePrimTyConKey) + (fromGhcUnique doublePrimTyConKey) #if MIN_VERSION_base(4,15,0) naturalPrimTyConName = mkUnsafeSystemName "GHC.Num.Natural.Natural" - (getKey naturalTyConKey) + (fromGhcUnique naturalTyConKey) #else naturalPrimTyConName = mkUnsafeSystemName "GHC.Natural.Natural" - (getKey naturalTyConKey) + (fromGhcUnique naturalTyConKey) #endif byteArrayPrimTyConName = mkUnsafeSystemName "GHC.Prim.ByteArray#" - (getKey byteArrayPrimTyConKey) + (fromGhcUnique byteArrayPrimTyConKey) -eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (getKey eqPrimTyConKey) +eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (fromGhcUnique eqPrimTyConKey) #if !MIN_VERSION_ghc(9,2,0) voidPrimTyConName :: TyConName -voidPrimTyConName = mkUnsafeSystemName "Void#" (getKey voidPrimTyConKey) +voidPrimTyConName = mkUnsafeSystemName "Void#" (fromGhcUnique voidPrimTyConKey) #endif #if MIN_VERSION_ghc(8,8,0) int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word32PrimTyConName :: TyConName -int8PrimTyConName = mkUnsafeSystemName (showt ''Int8#) (getKey int8PrimTyConKey) -int16PrimTyConName = mkUnsafeSystemName (showt ''Int16#) (getKey int16PrimTyConKey) -int32PrimTyConName = mkUnsafeSystemName (showt ''Int32#) (getKey int32PrimTyConKey) -word8PrimTyConName = mkUnsafeSystemName (showt ''Word8#) (getKey word8PrimTyConKey) -word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#) (getKey word16PrimTyConKey) -word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#) (getKey word32PrimTyConKey) +int8PrimTyConName = mkUnsafeSystemName (showt ''Int8#) + (fromGhcUnique int8PrimTyConKey) +int16PrimTyConName = mkUnsafeSystemName (showt ''Int16#) + (fromGhcUnique int16PrimTyConKey) +int32PrimTyConName = mkUnsafeSystemName (showt ''Int32#) + (fromGhcUnique int32PrimTyConKey) +word8PrimTyConName = mkUnsafeSystemName (showt ''Word8#) + (fromGhcUnique word8PrimTyConKey) +word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#) + (fromGhcUnique word16PrimTyConKey) +word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#) + (fromGhcUnique word32PrimTyConKey) #endif liftedPrimTC :: TyConName @@ -167,7 +176,7 @@ integerPrimTc = let name = integerPrimTyConName uniq = nameUniq name - isDcNm = mkUnsafeSystemName (showt 'IS) (getKey integerISDataConKey) + isDcNm = mkUnsafeSystemName (showt 'IS) (fromGhcUnique integerISDataConKey) isDc = MkData { dcName = isDcNm , dcUniq = nameUniq isDcNm @@ -179,7 +188,7 @@ integerPrimTc = , dcArgStrict = [Strict] , dcFieldLabels = [] } - ipDcNm = mkUnsafeSystemName (showt 'IP) (getKey integerIPDataConKey) + ipDcNm = mkUnsafeSystemName (showt 'IP) (fromGhcUnique integerIPDataConKey) ipDc = MkData { dcName = ipDcNm , dcUniq = nameUniq ipDcNm @@ -191,7 +200,7 @@ integerPrimTc = , dcArgStrict = [Strict] , dcFieldLabels = [] } - inDcNm = mkUnsafeSystemName (showt 'IN) (getKey integerINDataConKey) + inDcNm = mkUnsafeSystemName (showt 'IN) (fromGhcUnique integerINDataConKey) inDc = MkData { dcName = inDcNm , dcUniq = nameUniq inDcNm @@ -211,7 +220,7 @@ naturalPrimTc = let name = naturalPrimTyConName uniq = nameUniq name - nsDcNm = mkUnsafeSystemName (showt 'NS) (getKey naturalNSDataConKey) + nsDcNm = mkUnsafeSystemName (showt 'NS) (fromGhcUnique naturalNSDataConKey) nsDc = MkData { dcName = nsDcNm , dcUniq = nameUniq nsDcNm @@ -223,7 +232,7 @@ naturalPrimTc = , dcArgStrict = [Strict] , dcFieldLabels = [] } - nbDcNm = mkUnsafeSystemName (showt 'NB) (getKey naturalNBDataConKey) + nbDcNm = mkUnsafeSystemName (showt 'NB) (fromGhcUnique naturalNBDataConKey) nbDc = MkData { dcName = nbDcNm , dcUniq = nameUniq nbDcNm diff --git a/clash-lib/src/Clash/Core/Util.hs b/clash-lib/src/Clash/Core/Util.hs index c86e9f1a03..ad8bc468f4 100644 --- a/clash-lib/src/Clash/Core/Util.hs +++ b/clash-lib/src/Clash/Core/Util.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente, - 2021-2023, QBayLogic B.V., + 2021-2024, QBayLogic B.V., 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -35,10 +35,8 @@ import GHC.Stack (HasCallStack) #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (ipClassKey) -import GHC.Types.Unique (getKey) #else import PrelNames (ipClassKey) -import Unique (getKey) #endif import Clash.Core.DataCon @@ -58,6 +56,7 @@ import Clash.Core.Var (Id, Var(..), mkLocalId, mkTyVar) import Clash.Core.VarEnv import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (traceIf) +import Clash.Unique (fromGhcUnique) import Clash.Util -- | Rebuild a let expression / let expressions by taking the SCCs of a list @@ -673,7 +672,7 @@ splitShouldSplit tcm = foldr go [] -- | Strip implicit parameter wrappers (IP) stripIP :: Type -> Type stripIP t@(tyView -> TyConApp tcNm [_a1, a2]) = - if nameUniq tcNm == getKey ipClassKey then a2 else t + if nameUniq tcNm == fromGhcUnique ipClassKey then a2 else t stripIP t = t -- | Do an inverse topological sorting of the let-bindings in a let-expression diff --git a/clash-lib/src/Clash/Driver.hs b/clash-lib/src/Clash/Driver.hs index c15a24a981..c1e6605317 100644 --- a/clash-lib/src/Clash/Driver.hs +++ b/clash-lib/src/Clash/Driver.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , QBayLogic, Google Inc. - 2020-2023, QBayLogic, + 2020-2024, QBayLogic, 2022 , Google Inc. License : BSD2 (see the file LICENSE) @@ -88,12 +88,10 @@ import Text.Trifecta.Result #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqTyConKey, ipClassKey) -import GHC.Types.Unique (getKey) import GHC.Types.SrcLoc (SrcSpan) #else import PrelNames (eqTyConKey, ipClassKey) -import Unique (getKey) import SrcLoc (SrcSpan) #endif @@ -147,7 +145,7 @@ import qualified Clash.Primitives.Verification as P import qualified Clash.Primitives.Xilinx.ClockGen as P import Clash.Primitives.Types import Clash.Signal.Internal -import Clash.Unique (Unique, getUnique) +import Clash.Unique (Unique, getUnique, fromGhcUnique) import Clash.Util (ClashException(..), reportTimeDiff, wantedLanguageExtensions, unwantedLanguageExtensions, curLoc) @@ -219,8 +217,8 @@ splitTopAnn tcm sp typ@(tyView -> FunTy {}) t@Synthesize{t_inputs} = -- * HasCallStack shouldNotHavePortName :: Type -> Bool shouldNotHavePortName (tyView -> TyConApp (nameUniq -> tcUniq) tcArgs) - | tcUniq == getKey eqTyConKey = True - | tcUniq == getKey ipClassKey + | tcUniq == fromGhcUnique eqTyConKey = True + | tcUniq == fromGhcUnique ipClassKey , [LitTy (SymTy "callStack"), _] <- tcArgs = True shouldNotHavePortName _ = False diff --git a/clash-lib/src/Clash/Normalize/PrimitiveReductions.hs b/clash-lib/src/Clash/Normalize/PrimitiveReductions.hs index 0ed66c7c71..2f2348dbde 100644 --- a/clash-lib/src/Clash/Normalize/PrimitiveReductions.hs +++ b/clash-lib/src/Clash/Normalize/PrimitiveReductions.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2016 , Myrtle Software Ltd, - 2021 , QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -45,7 +45,12 @@ import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Bifunctor (second) import Data.List (mapAccumR) import Data.List.Extra (zipEqual) +#if MIN_VERSION_base(4,20,0) +import qualified Data.List.NonEmpty as NE hiding (unzip) +import qualified Data.Functor as NE +#else import qualified Data.List.NonEmpty as NE +#endif import qualified Data.Maybe as Maybe import Data.Semigroup (sconcat) import Data.Text.Extra (showt) @@ -55,13 +60,11 @@ import GHC.Stack (HasCallStack) import GHC.Builtin.Names (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey) -import GHC.Types.Unique (getKey) import GHC.Types.SrcLoc (wiredInSrcSpan) #else import PrelNames (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey) -import Unique (getKey) import SrcLoc (wiredInSrcSpan) #endif @@ -93,20 +96,21 @@ import {-# SOURCE #-} Clash.Normalize.Strategy import Clash.Normalize.Types import Clash.Rewrite.Types import Clash.Rewrite.Util +import Clash.Unique (fromGhcUnique) import Clash.Util import qualified Clash.Util.Interpolate as I typeNatAdd :: TyConName typeNatAdd = - Name User "GHC.TypeNats.+" (getKey typeNatAddTyFamNameKey) wiredInSrcSpan + Name User "GHC.TypeNats.+" (fromGhcUnique typeNatAddTyFamNameKey) wiredInSrcSpan typeNatMul :: TyConName typeNatMul = - Name User "GHC.TypeNats.*" (getKey typeNatMulTyFamNameKey) wiredInSrcSpan + Name User "GHC.TypeNats.*" (fromGhcUnique typeNatMulTyFamNameKey) wiredInSrcSpan typeNatSub :: TyConName typeNatSub = - Name User "GHC.TypeNats.-" (getKey typeNatSubTyFamNameKey) wiredInSrcSpan + Name User "GHC.TypeNats.-" (fromGhcUnique typeNatSubTyFamNameKey) wiredInSrcSpan vecHeadPrim :: TyConName @@ -1072,7 +1076,7 @@ reduceReplace_int n aTy vTy _kn v i newA (TransformContext is0 _ctx) = do replace_intElement tcm iDc iTy oldA elIndex = case0 where case0 = Maybe.fromMaybe (error "replace_intElement: faild to build Truce DC") $ do - boolTc <- UniqMap.lookup (getKey boolTyConKey) tcm + boolTc <- UniqMap.lookup (fromGhcUnique boolTyConKey) tcm [_,trueDc] <- pure (tyConDataCons boolTc) let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) return (Case (mkApps eqInt [ Left i @@ -1181,7 +1185,7 @@ reduceIndex_int n aTy _kn v i (TransformContext is0 _ctx) = do index_intElement tcm iDc iTy (cur,elIndex) next = case0 where case0 = Maybe.fromMaybe (error "reduceIndex_int: faild to build True DC") $ do - boolTc <- UniqMap.lookup (getKey boolTyConKey) tcm + boolTc <- UniqMap.lookup (fromGhcUnique boolTyConKey) tcm [_,trueDc] <- pure (tyConDataCons boolTc) let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) return (Case (mkApps eqInt [ Left i diff --git a/clash-lib/src/Clash/Normalize/Transformations/Case.hs b/clash-lib/src/Clash/Normalize/Transformations/Case.hs index c2439c5747..b827ef4598 100644 --- a/clash-lib/src/Clash/Normalize/Transformations/Case.hs +++ b/clash-lib/src/Clash/Normalize/Transformations/Case.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations on case-expressions diff --git a/clash-lib/src/Clash/Normalize/Util.hs b/clash-lib/src/Clash/Normalize/Util.hs index 910f07b2cf..65311dd542 100644 --- a/clash-lib/src/Clash/Normalize/Util.hs +++ b/clash-lib/src/Clash/Normalize/Util.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente, - 2021-2022, QBayLogic B.V. + 2021-2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -48,10 +48,8 @@ import qualified Data.Text.Extra as Text #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqTyConKey) -import GHC.Types.Unique (getKey) #else import PrelNames (eqTyConKey) -import Unique (getKey) #endif import Clash.Annotations.Primitive (extractPrim) @@ -450,7 +448,7 @@ substWithTyEq e0 = go [] False e0 go args changed (TyLam tv e) = go (Right tv : args) changed e go args changed (Lam v e) | TyConApp (nameUniq -> tcUniq) (tvFirst -> Just (tv, ty)) <- tyView (coreTypeOf v) - , tcUniq == getKey eqTyConKey + , tcUniq == fromGhcUnique eqTyConKey , Right tv `elem` args = let tvs = rights args @@ -479,7 +477,7 @@ tvSubstWithTyEq ty0 = go [] False ty0 = go (Left tv:argsOut) changed ty go argsOut changed (tyView -> FunTy arg tyRes) | Just (tc,tcArgs) <- splitTyConAppM arg - , nameUniq tc == getKey eqTyConKey + , nameUniq tc == fromGhcUnique eqTyConKey , Just (tv,ty) <- tvFirst tcArgs = let argsOut2 = Right arg : (argsOut List.\\ [Left tv]) diff --git a/clash-lib/src/Clash/Unique.hs b/clash-lib/src/Clash/Unique.hs index 942590209d..e0bba65cf6 100644 --- a/clash-lib/src/Clash/Unique.hs +++ b/clash-lib/src/Clash/Unique.hs @@ -1,10 +1,25 @@ +{-| + Copyright : (C) 2024, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. +-} + +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} module Clash.Unique ( Unique , Uniquable (..) + , fromGhcUnique ) where +import Data.Word (Word64) +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Types.Unique as GHC +#else +import qualified Unique as GHC +#endif + type Unique = Int class Uniquable a where @@ -14,3 +29,15 @@ class Uniquable a where instance Uniquable Unique where getUnique = id setUnique = flip const + +instance Uniquable Word64 where + getUnique = fromIntegral + setUnique _ = fromIntegral + +#if MIN_VERSION_ghc(9,10,0) +fromGhcUnique :: GHC.Unique -> Unique +fromGhcUnique = fromIntegral . GHC.getKey +#else +fromGhcUnique :: GHC.Unique -> Unique +fromGhcUnique = id . GHC.getKey +#endif diff --git a/clash-lib/src/Data/Aeson/Extra.hs b/clash-lib/src/Data/Aeson/Extra.hs index f7628754c3..1f8905538f 100644 --- a/clash-lib/src/Data/Aeson/Extra.hs +++ b/clash-lib/src/Data/Aeson/Extra.hs @@ -1,5 +1,6 @@ {-| Copyright : (C) 2015-2016, University of Twente + 2024, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} @@ -23,7 +24,12 @@ import qualified Data.Text.Lazy.Encoding as LT import Data.Text.Encoding.Error (UnicodeException(..)) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) +#if MIN_VERSION_base(4,20,0) +import qualified Data.List.NonEmpty as NE hiding (unzip) +import qualified Data.Functor as NE +#else import qualified Data.List.NonEmpty as NE +#endif import Data.Tuple.Extra (second, first) import Data.Aeson (FromJSON, Result (..), fromJSON) import Data.Aeson.Parser (json) From ed92b236a742677a6bc287dac4a5bdad5c9bc171 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Sun, 21 Jul 2024 07:42:28 +0200 Subject: [PATCH 03/18] Add source for GHC 9.10 executable (cherry picked from commit b32dec801d8df4826ec9f3b499909808431becb7) --- clash-ghc/src-bin-9.10/Clash/GHCi/Leak.hs | 85 + clash-ghc/src-bin-9.10/Clash/GHCi/UI.hs | 4739 +++++++++++++++++ .../src-bin-9.10/Clash/GHCi/UI/Exception.hs | 141 + clash-ghc/src-bin-9.10/Clash/GHCi/UI/Info.hs | 409 ++ clash-ghc/src-bin-9.10/Clash/GHCi/UI/Monad.hs | 575 ++ clash-ghc/src-bin-9.10/Clash/GHCi/Util.hs | 16 + clash-ghc/src-bin-9.10/Clash/Main.hs | 1145 ++++ 7 files changed, 7110 insertions(+) create mode 100644 clash-ghc/src-bin-9.10/Clash/GHCi/Leak.hs create mode 100644 clash-ghc/src-bin-9.10/Clash/GHCi/UI.hs create mode 100644 clash-ghc/src-bin-9.10/Clash/GHCi/UI/Exception.hs create mode 100644 clash-ghc/src-bin-9.10/Clash/GHCi/UI/Info.hs create mode 100644 clash-ghc/src-bin-9.10/Clash/GHCi/UI/Monad.hs create mode 100644 clash-ghc/src-bin-9.10/Clash/GHCi/Util.hs create mode 100644 clash-ghc/src-bin-9.10/Clash/Main.hs diff --git a/clash-ghc/src-bin-9.10/Clash/GHCi/Leak.hs b/clash-ghc/src-bin-9.10/Clash/GHCi/Leak.hs new file mode 100644 index 0000000000..51e3958ba2 --- /dev/null +++ b/clash-ghc/src-bin-9.10/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.10/Clash/GHCi/UI.hs b/clash-ghc/src-bin-9.10/Clash/GHCi/UI.hs new file mode 100644 index 0000000000..0a5b842e85 --- /dev/null +++ b/clash-ghc/src-bin-9.10/Clash/GHCi/UI.hs @@ -0,0 +1,4739 @@ +{-# 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 + +-- 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.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 ) +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 ( orElse, expectJust ) +import GHC.Types.Name.Set +import GHC.Utils.Panic hiding ( showException, try ) +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.Bag (unitBag) +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), + ("check", keepGoing' checkModule, completeHomeModule), + ("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