Hannes Siebenhandl pushed to branch wip/fendor/infoprov-id at Glasgow Haskell Compiler / GHC Commits: 58644c6d by Sylvain Henry at 2025-11-11T14:35:22+01:00 Testsuite: pass ext-interp test way (#26552) Note that some tests are still marked as broken with the ext-interp way (see #26552 and #14335) - - - - - 7 changed files: - libraries/base/tests/all.T - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghci/GHCi/Message.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T20696/all.T - testsuite/tests/driver/fat-iface/all.T - testsuite/tests/splice-imports/all.T Changes: ===================================== libraries/base/tests/all.T ===================================== @@ -80,7 +80,7 @@ test('length001', # excessive amounts of stack space. So we specifically set a low # stack limit and mark it as failing under a few conditions. [extra_run_opts('+RTS -K8m -RTS'), - expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']), + expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc', 'ext-interp']), # JS doesn't support stack limit so the test sometimes passes just fine. Therefore the test is # marked as fragile. when(js_arch(), fragile(22921))], ===================================== libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc ===================================== @@ -15,12 +15,13 @@ module GHC.Internal.InfoProv.Types , getIPE , StgInfoTable , lookupIPE + , lookupIpId ) where import GHC.Internal.Base import GHC.Internal.Enum import GHC.Internal.Real (fromIntegral) -import GHC.Internal.Word (Word32) +import GHC.Internal.Word (Word32, Word64) import GHC.Internal.Show (Show) import GHC.Internal.Ptr (Ptr(..), plusPtr) import GHC.Internal.Foreign.C.String.Encoding (CString, peekCString) @@ -32,6 +33,8 @@ import GHC.Internal.ClosureTypes import GHC.Internal.Prim (whereFrom##) data InfoProv = InfoProv { + -- | @since base-4.23.0.0 + ipId :: Word64, ipName :: String, ipDesc :: ClosureType, ipTyDesc :: String, @@ -59,6 +62,16 @@ lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do 1 -> Just `fmap` peekInfoProv (ipeProv p) _ -> return Nothing +-- | Lookup the stable Id 'ipId' of the 'InfoProv'. +-- Equivalent to @'fmap' 'ipProvId' <$> 'lookupIPE' ptr@, +-- but performs fewer lookups. +lookupIpId :: Ptr StgInfoTable -> IO (Maybe Word64) +lookupIpId itbl = allocaBytes (#size InfoProvEnt) $ \p -> do + res <- c_lookupIPE itbl p + case res of + 1 -> Just `fmap` peekIpId (ipeProv p) + _ -> return Nothing + getIPE :: a -> r -> (Ptr InfoProvEnt -> IO r) -> IO r getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s -> case whereFrom## obj (unPtr p) s of @@ -73,6 +86,9 @@ ipeProv p = (#ptr InfoProvEnt, prov) p peekIpDesc :: Ptr InfoProv -> IO Word32 peekIpDesc p = (# peek InfoProv, closure_desc) p +peekIpId :: Ptr InfoProv -> IO Word64 +peekIpId p = (# peek InfoProv, info_prov_id) p + peekIpName, peekIpLabel, peekIpUnitId, peekIpModule, peekIpSrcFile, peekIpSrcSpan, peekIpTyDesc :: Ptr InfoProv -> IO CString peekIpName p = (# peek InfoProv, table_name) p peekIpLabel p = (# peek InfoProv, label) p @@ -84,6 +100,7 @@ peekIpTyDesc p = (# peek InfoProv, ty_desc) p peekInfoProv :: Ptr InfoProv -> IO InfoProv peekInfoProv infop = do + provId <- peekIpId infop name <- peekCString utf8 =<< peekIpName infop desc <- peekIpDesc infop tyDesc <- peekCString utf8 =<< peekIpTyDesc infop @@ -93,6 +110,7 @@ peekInfoProv infop = do file <- peekCString utf8 =<< peekIpSrcFile infop span <- peekCString utf8 =<< peekIpSrcSpan infop return InfoProv { + ipId = provId, ipName = name, -- The INVALID_OBJECT case should be impossible as we -- control the C code generating these values. ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -545,7 +545,11 @@ instance Binary Heap.ClosureType instance Binary Heap.PrimType instance Binary a => Binary (Heap.GenClosure a) instance Binary InfoProv where -#if MIN_VERSION_base(4,20,0) +#if MIN_VERSION_base(4,22,0) + get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get + put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8 x9) + = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 >> put x9 +#elif MIN_VERSION_base(4,20,0) get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8) = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 ===================================== testsuite/driver/testlib.py ===================================== @@ -352,6 +352,9 @@ def req_plugins( name, opts ): """ req_interp(name, opts) + # Plugins aren't supported with the external interpreter (#14335) + expect_broken_for(14335,['ext-interp'])(name,opts) + if config.cross: opts.skip = True ===================================== testsuite/tests/driver/T20696/all.T ===================================== @@ -1,4 +1,5 @@ test('T20696', [extra_files(['A.hs', 'B.hs', 'C.hs']) + , expect_broken_for(26552, ['ext-interp']) , unless(ghc_dynamic(), skip)], multimod_compile, ['A', '']) test('T20696-static', [extra_files(['A.hs', 'B.hs', 'C.hs']) , when(ghc_dynamic(), skip)], multimod_compile, ['A', '']) ===================================== testsuite/tests/driver/fat-iface/all.T ===================================== @@ -9,12 +9,12 @@ test('fat010', [req_th,extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files], # Check linking works when using -fbyte-code-and-object-code test('fat011', [req_th, extra_files(['FatMain.hs', 'FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatMain', '-fbyte-code-and-object-code -fprefer-byte-code']) # Check that we use interpreter rather than enable dynamic-too if needed for TH -test('fat012', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code']) +test('fat012', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code']) # Check that no objects are generated if using -fno-code and -fprefer-byte-code test('fat013', [req_th, req_bco, extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code']) # When using interpreter should not produce objects test('fat014', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script']) -test('fat015', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface']) +test('fat015', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface']) test('T22807', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807A.hs', 'T22807B.hs'])] , makefile_test, ['T22807']) test('T22807_ghci', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807_ghci.hs'])] ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -9,7 +9,7 @@ test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0'] test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0']) test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0']) test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0']) -test('SI07', [unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code']) +test('SI07', [expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code']) # Instance tests test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0']) test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58644c6db8155e82cf5258af47afb2db... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58644c6db8155e82cf5258af47afb2db... You're receiving this email because of your account on gitlab.haskell.org.