- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/ghc-sample-profiler] Sample Profiler commit
by Hannes Siebenhandl (＠fendor) 30 Oct '25

30 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC Commits: fe1b7b91 by fendor at 2025-10-30T10:19:24+01:00 Sample Profiler commit - - - - - 7 changed files: - .gitmodules - + eventlog-live-profiling-prototype - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs Changes: ===================================== .gitmodules ===================================== @@ -124,3 +124,6 @@ [submodule "libraries/template-haskell-quasiquoter"] path = libraries/template-haskell-quasiquoter url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git +[submodule "eventlog-live-profiling-prototype"] + path = eventlog-live-profiling-prototype + url = git@gitlab.well-typed.com:well-typed/eventlog-live-profiling-prototype.git ===================================== eventlog-live-profiling-prototype ===================================== @@ -0,0 +1 @@ +Subproject commit db767230707a50f206ec446e63b7de6bca92dcf0 ===================================== ghc/Main.hs ===================================== @@ -80,6 +80,7 @@ import GHC.Iface.Errors.Ppr import GHC.Driver.Session.Mode import GHC.Driver.Session.Lint import GHC.Driver.Session.Units +import GHC.Driver.Monad -- Standard Haskell libraries import System.IO @@ -91,6 +92,17 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(SAMPLE_TRACER) +import Sampler +#endif + +runWithSampleProfiler :: IO () -> IO () +runWithSampleProfiler = +#if defined(SAMPLE_TRACER) + withSampleProfiler 10000 {- Every 10 ms -} +#else + id +#endif ----------------------------------------------------------------------------- -- ToDo: @@ -153,7 +165,8 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + reifyGhc $ \session -> runWithSampleProfiler $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -27,6 +27,11 @@ Flag threaded Default: True Manual: True +Flag sampleTracer + Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled + Default: False + Manual: True + Executable ghc Default-Language: GHC2021 @@ -45,6 +50,10 @@ Executable ghc ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + build-depends: ghc-sampler-eventlog + CPP-OPTIONS: -DSAMPLE_TRACER + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -13,6 +13,7 @@ module Packages ( transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, ghcPackages, isGhcPackage, + ghc_sampler_eventlog, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -43,7 +44,8 @@ ghcPackages = , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , ghc_sampler_eventlog + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -135,6 +137,7 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +ghc_sampler_eventlog = lib "ghc-sampler-eventlog" `setPath` "eventlog-live-profiling-prototype/sampler" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -180,6 +180,7 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_sampler_eventlog ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -108,6 +108,12 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_sampler_eventlog ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe1b7b91ab91a61aaa43d361f16a505… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe1b7b91ab91a61aaa43d361f16a505… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: rts: remove unneccesary cabal flags
by Marge Bot (＠marge-bot) 30 Oct '25

30 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 643ce801 by Julian Ospald at 2025-10-28T18:18:55-04:00 rts: remove unneccesary cabal flags We perform those checks via proper autoconf macros instead that do the right thing and then add those libs to the rts buildinfo. - - - - - d69ea8fe by Vladislav Zavialov at 2025-10-28T18:19:37-04:00 Test case for #17705 Starting with GHC 9.12 (the first release to include 5745dbd3), all examples in this ticket are handled as expected. - - - - - 1c13c171 by Andreas Klebinger at 2025-10-30T04:58:28-04:00 Add a perf test for #26425 - - - - - 6044b81e by Andreas Klebinger at 2025-10-30T04:58:28-04:00 OccAnal: Be stricter for better compiler perf. In particular we are now stricter: * When combining usageDetails. * When computing binder info. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. We also force binders we put into the Core AST everywhere now. Failure to do so risks leaking the occ env used to set the binders OccInfo. For T26425 compiler residency went down by a factor of ~10x. Compile time also improved by a factor of ~1.6. ------------------------- Metric Decrease: T18698a T26425 T9233 ------------------------- - - - - - 46bf1b58 by Vladislav Zavialov at 2025-10-30T04:58:29-04:00 Fix namespace specifiers in subordinate exports (#12488) This patch fixes an oversight in the `lookupChildrenExport` function that caused explicit namespace specifiers of subordinate export items to be ignored: module M (T (type A)) where -- should be rejected data T = A Based on the `IEWrappedName` data type, there are 5 cases to consider: 1. Unadorned name: P(X) 2. Named default: P(default X) 3. Pattern synonym: P(pattern X) 4. Type name: P(type X) 5. Data name: P(data X) Case 1 is already handled correctly; cases 2 and 3 are parse errors; and it is cases 4 and 5 that we are concerned with in this patch. Following the precedent established in `LookupExactName`, we introduce a boolean flag in `LookupChildren` to control whether to look up in all namespaces or in a specific one. If an export item is accompanied by an explicit namespace specifier `type` or `data`, we restrict the lookup in `lookupGRE` to a specific namespace. The newly introduced diagnostic `TcRnExportedSubordinateNotFound` provides error messages and suggestions more tailored to this context than the previously used `reportUnboundName`. - - - - - 39 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs - m4/fp_check_pthreads.m4 - rts/configure.ac - + rts/rts.buildinfo.in - rts/rts.cabal - testsuite/tests/module/mod4.stderr - + testsuite/tests/parser/should_fail/T12488c.hs - + testsuite/tests/parser/should_fail/T12488c.stderr - + testsuite/tests/parser/should_fail/T12488d.hs - + testsuite/tests/parser/should_fail/T12488d.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/perf/compiler/T26425.hs - testsuite/tests/perf/compiler/all.T - + testsuite/tests/rename/should_compile/T12488b.hs - + testsuite/tests/rename/should_compile/T12488f.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T12488a.hs - + testsuite/tests/rename/should_fail/T12488a.stderr - + testsuite/tests/rename/should_fail/T12488a_foo.hs - + testsuite/tests/rename/should_fail/T12488a_foo.stderr - + testsuite/tests/rename/should_fail/T12488e.hs - + testsuite/tests/rename/should_fail/T12488e.stderr - + testsuite/tests/rename/should_fail/T12488g.hs - + testsuite/tests/rename/should_fail/T12488g.stderr - testsuite/tests/rename/should_fail/T25899e2.stderr - testsuite/tests/rename/should_fail/all.T - + testsuite/tests/typecheck/should_compile/T17705.hs - testsuite/tests/typecheck/should_compile/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/02009f802e02507b626f33449a5b61… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/02009f802e02507b626f33449a5b61… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ghc-sample-profiler] 2 commits: Expose more stack decoding details
by Hannes Siebenhandl (＠fendor) 30 Oct '25

30 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC Commits: 3ff55063 by fendor at 2025-10-29T15:51:02+01:00 Expose more stack decoding details - - - - - 7d53eed9 by fendor at 2025-10-29T16:13:07+01:00 Sample Profiler commit - - - - - 10 changed files: - .gitmodules - + eventlog-live-profiling-prototype - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghci/GHCi/Message.hs Changes: ===================================== .gitmodules ===================================== @@ -124,3 +124,6 @@ [submodule "libraries/template-haskell-quasiquoter"] path = libraries/template-haskell-quasiquoter url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git +[submodule "eventlog-live-profiling-prototype"] + path = eventlog-live-profiling-prototype + url = git@gitlab.well-typed.com:well-typed/eventlog-live-profiling-prototype.git ===================================== eventlog-live-profiling-prototype ===================================== @@ -0,0 +1 @@ +Subproject commit 4ebbfbfffd3dd255a661414b5d7c9a990ff4f4fc ===================================== ghc/Main.hs ===================================== @@ -80,6 +80,7 @@ import GHC.Iface.Errors.Ppr import GHC.Driver.Session.Mode import GHC.Driver.Session.Lint import GHC.Driver.Session.Units +import GHC.Driver.Monad -- Standard Haskell libraries import System.IO @@ -91,6 +92,17 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(SAMPLE_TRACER) +import Sampler +#endif + +runWithSampleProfiler :: IO () -> IO () +runWithSampleProfiler = +#if defined(SAMPLE_TRACER) + withSampleProfiler 10000 {- Every 10 ms -} +#else + id +#endif ----------------------------------------------------------------------------- -- ToDo: @@ -153,7 +165,8 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + reifyGhc $ \session -> runWithSampleProfiler $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -27,6 +27,11 @@ Flag threaded Default: True Manual: True +Flag sampleTracer + Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled + Default: False + Manual: True + Executable ghc Default-Language: GHC2021 @@ -45,6 +50,10 @@ Executable ghc ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + build-depends: ghc-sampler-eventlog + CPP-OPTIONS: -DSAMPLE_TRACER + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -13,6 +13,7 @@ module Packages ( transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, ghcPackages, isGhcPackage, + ghc_sampler_eventlog, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -43,7 +44,8 @@ ghcPackages = , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , ghc_sampler_eventlog + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -135,6 +137,7 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +ghc_sampler_eventlog = lib "ghc-sampler-eventlog" `setPath` "eventlog-live-profiling-prototype/sampler" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -180,6 +180,7 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_sampler_eventlog ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -108,6 +108,12 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_sampler_eventlog ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat ===================================== libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc ===================================== @@ -15,12 +15,13 @@ module GHC.Internal.InfoProv.Types , getIPE , StgInfoTable , lookupIPE + , lookupIpProvId ) 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,7 @@ import GHC.Internal.ClosureTypes import GHC.Internal.Prim (whereFrom##) data InfoProv = InfoProv { + ipProvId :: Word64, ipName :: String, ipDesc :: ClosureType, ipTyDesc :: String, @@ -59,6 +61,13 @@ lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do 1 -> Just `fmap` peekInfoProv (ipeProv p) _ -> return Nothing +lookupIpProvId :: Ptr StgInfoTable -> IO (Maybe Word64) +lookupIpProvId itbl = allocaBytes (#size InfoProvEnt) $ \p -> do + res <- c_lookupIPE itbl p + case res of + 1 -> Just `fmap` peekIpProvId (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 +82,9 @@ ipeProv p = (#ptr InfoProvEnt, prov) p peekIpDesc :: Ptr InfoProv -> IO Word32 peekIpDesc p = (# peek InfoProv, closure_desc) p +peekIpProvId :: Ptr InfoProv -> IO Word64 +peekIpProvId 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 +96,7 @@ peekIpTyDesc p = (# peek InfoProv, ty_desc) p peekInfoProv :: Ptr InfoProv -> IO InfoProv peekInfoProv infop = do + provId <- peekIpProvId infop name <- peekCString utf8 =<< peekIpName infop desc <- peekIpDesc infop tyDesc <- peekCString utf8 =<< peekIpTyDesc infop @@ -93,6 +106,7 @@ peekInfoProv infop = do file <- peekCString utf8 =<< peekIpSrcFile infop span <- peekCString utf8 =<< peekIpSrcSpan infop return InfoProv { + ipProvId = provId, ipName = name, -- The INVALID_OBJECT case should be impossible as we -- control the C code generating these values. ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -25,6 +25,10 @@ module GHC.Internal.Stack.Decode ( -- * Pretty printing prettyStackEntry, prettyStackFrameWithIpe, + -- * Low level decoding functions + StackFrameLocation(..), + unpackStackFrameTo, + getStackFields, ) where @@ -69,6 +73,7 @@ import GHC.Internal.Stack.ConstantsProf () #endif import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) +import qualified GHC.Internal.InfoProv.Types as IPE {- Note [Decoding the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -186,11 +191,11 @@ foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSna -- | Get the 'StgInfoTable' of the stack frame. -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Ptr IPE.StgInfoTable) getInfoTableOnStack stackSnapshot# index = let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) in - (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#) + (,) <$> peekItbl (Ptr itbl_struct#) <*> pure (Ptr itbl_ptr_ipe_key#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -324,8 +329,9 @@ unpackStackFrame stackFrameLoc = do unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] unpackStackFrameWithIpe stackFrameLoc = do unpackStackFrameTo stackFrameLoc - (\ info mIpe nextChunk@(StackSnapshot stack#) -> do + (\ info infoKey nextChunk@(StackSnapshot stack#) -> do framesWithIpe <- decodeStackWithIpe nextChunk + mIpe <- lookupIPE infoKey pure [ ( UnderflowFrame { info_tbl = info, @@ -340,22 +346,26 @@ unpackStackFrameWithIpe stackFrameLoc = do ) ] ) - (\ frame mIpe -> pure [(frame, mIpe)]) + (\ frame infoKey -> do + mIpe <- lookupIPE infoKey + pure [(frame, mIpe)]) unpackStackFrameTo :: forall a . StackFrameLocation -> -- ^ Decode the given 'StackFrame'. - (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) -> + (StgInfoTable -> Ptr IPE.StgInfoTable -> StackSnapshot -> IO a) -> -- ^ How to handle 'UNDERFLOW_FRAME's. - (StackFrame -> Maybe InfoProv -> IO a) -> + -- The pointer is the key for the 'lookupIPE'. + (StackFrame -> Ptr IPE.StgInfoTable -> IO a) -> -- ^ How to handle all other 'StackFrame' values. + -- The pointer is the key for the 'lookupIPE'. IO a unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do - (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index + (info, infoTablePtr) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info - (unpackUnderflowFrame info m_info_prov) - (`finaliseStackFrame` m_info_prov) + (unpackUnderflowFrame info infoTablePtr) + (`finaliseStackFrame` infoTablePtr) where unpackStackFrame' :: StgInfoTable -> ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcf56eb3f0e03291e86b71f6979e87… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcf56eb3f0e03291e86b71f6979e87… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps
by Torsten Schmits (＠torsten.schmits) 29 Oct '25

29 Oct '25

Torsten Schmits pushed new branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/mercury-ghc91… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/mercury-mhu-transitive-th-deps] WIP: transitive TH deps with MHU
by Torsten Schmits (＠torsten.schmits) 29 Oct '25

29 Oct '25

Torsten Schmits pushed to branch wip/torsten.schmits/mercury-mhu-transitive-th-deps at Glasgow Haskell Compiler / GHC Commits: 8323b4b9 by Torsten Schmits at 2025-10-29T23:37:12+01:00 WIP: transitive TH deps with MHU - - - - - 14 changed files: - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - testsuite/tests/bytecode/T25090/all.T - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepA/A.hs - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepC/C.hs - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/Makefile - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/all.T - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/Dep1.hs - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/dep1.conf - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-bc.stdout - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-obj.stdout - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unita - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unitc Changes: ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Linker.Deps ( LinkDepsOpts (..) , LinkDeps (..) + , LibraryUnits (..) , getLinkDeps ) where @@ -84,10 +85,16 @@ data LinkDepsOpts = LinkDepsOpts data LinkDeps = LinkDeps { ldNeededLinkables :: [Linkable] , ldAllLinkables :: [Linkable] - , ldNeededUnits :: [UnitId] + , ldNeededUnits :: [LibraryUnits] , ldAllUnits :: UniqDSet UnitId } +data LibraryUnits + = LibraryUnits + { home_unit :: !UnitId + , library_unit :: !UnitId + } + -- | Find all the packages and linkables that a set of modules depends on -- -- Return the module and package dependencies for the needed modules. @@ -142,6 +149,7 @@ instance Outputable LinkExternalDetails where data LinkExternal = LinkExternal { le_details :: LinkExternalDetails, + le_unit_for_dbs :: !UnitId, le_module :: !Module } @@ -215,7 +223,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- entire set for oneshot mode. separate_home_deps = if ldOneShotMode opts - then pure ([], LinkExternal LinkAllDeps <$!> noninteractive) + then pure ([], LinkExternal LinkAllDeps (ue_currentUnit unit_env) <$!> noninteractive) else make_deps make_deps = do @@ -239,7 +247,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do Nothing -> let (ModNodeKeyWithUid (GWIB mod_name _) uid) = nk mod = Module (RealUnit (Definite uid)) mod_name - in make_deps_loop (LinkExternal LinkAllDeps mod : external, found_mods) nexts + in make_deps_loop (LinkExternal LinkAllDeps (ue_currentUnit unit_env) mod : external, found_mods) nexts Just trans_deps -> let deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps) -- See #936 and the ghci.prog007 test for why we have to continue traversing through @@ -256,7 +264,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of Just hmi -> do let iface = hm_iface hmi - pure (LinkExternal (LinkOnlyPackages iface) (mi_module iface), hmi) + mod = mi_module iface + pure (LinkExternal (LinkOnlyPackages iface) (moduleUnitId mod) mod, hmi) Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid @@ -319,12 +328,13 @@ get_link_deps opts pls maybe_normal_osuf span mods = do data LinkDep = LinkModules !(UniqDFM ModuleName LinkModule) | - LinkLibrary !UnitId + LinkLibrary !LibraryUnits instance Outputable LinkDep where ppr = \case LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods) - LinkLibrary uid -> text "library:" <+> ppr uid + LinkLibrary (LibraryUnits {home_unit, library_unit}) -> + text "library:" <+> ppr library_unit <+> parens (ppr home_unit) data OneshotError = NoInterface !MissingInterfaceError @@ -397,7 +407,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do already_seen | Just (LinkModules mods) <- mod_dep = elemUDFM mod_name mods - | Just (LinkLibrary _) <- mod_dep + | Just (LinkLibrary {}) <- mod_dep = True | otherwise = False @@ -429,7 +439,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do = add_library add_library = - pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [], Just "library") + pure (addToUDFM acc mod_unit_id (LinkLibrary (LibraryUnits {home_unit = le_unit_for_dbs, library_unit = mod_unit_id})), [], Just "library") add_module iface lmod action = with_deps with_mod iface True action @@ -437,7 +447,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do with_mod = alterUDFM (add_package_module lmod) acc mod_unit_id add_package_module lmod = \case - Just (LinkLibrary u) -> Just (LinkLibrary u) + Just (LinkLibrary lib) -> Just (LinkLibrary lib) Just (LinkModules old) -> Just (LinkModules (addToUDFM old mod_name lmod)) Nothing -> Just (LinkModules (unitUDFM mod_name lmod)) @@ -449,7 +459,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do local_deps iface = [ - LinkExternal LinkAllDeps (mkModule mod_unit m) + LinkExternal LinkAllDeps le_unit_for_dbs (mkModule mod_unit m) | (_, GWIB m _) <- Set.toList (dep_direct_mods (mi_deps iface)) ] @@ -458,9 +468,9 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do -- Otherwise, link all package deps as libraries. package_deps iface | package_bc - = ([], [LinkExternal LinkAllDeps usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]) + = ([], [LinkExternal LinkAllDeps le_unit_for_dbs usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]) | otherwise - = ([(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) + = ([(u, LinkLibrary (LibraryUnits {home_unit = le_unit_for_dbs, library_unit = u})) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) load_reason = text "need to link module" <+> ppr mod <+> @@ -500,7 +510,7 @@ classify_deps :: LoaderState -> [HomeModInfo] -> [LinkDep] -> - ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + ([Linkable], [LinkModule], UniqDSet UnitId, [LibraryUnits]) classify_deps pls hmis deps = (loaded_modules' ++ loaded_modules'', needed_modules' ++ needed_modules'', all_packages, needed_packages) where @@ -509,11 +519,13 @@ classify_deps pls hmis deps = partitionWith loaded_or_needed_module (concatMap eltsUDFM modules) needed_packages = - eltsUDFM (getUniqDSet all_packages `minusUDFM` pkgs_loaded pls) + eltsUDFM (packages `minusUDFM` pkgs_loaded pls) + + packages = listToUDFM [(library_unit p, p) | p <- packages_with_home_units] - all_packages = mkUniqDSet packages + all_packages = mkUniqDSet (map library_unit packages_with_home_units) - (modules, packages) = flip partitionWith deps $ \case + (modules, packages_with_home_units) = flip partitionWith deps $ \case LinkModules mods -> Left mods LinkLibrary lib -> Right lib ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -95,9 +95,10 @@ import Control.Monad import qualified Data.Set as Set import Data.Char (isSpace) +import Data.Foldable (for_) import Data.Functor ((<&>)) import Data.IORef -import Data.List (intercalate, isPrefixOf, nub, partition) +import Data.List (intercalate, isPrefixOf, nub, partition, sortOn) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC @@ -177,7 +178,7 @@ emptyLoaderState = LoaderState -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId Nothing [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = @@ -329,9 +330,8 @@ reallyInitLoaderState interp hsc_env = do -- (a) initialise the C dynamic linker initObjLinker interp - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp hsc_env [LibraryUnits {home_unit = u, library_unit = pre} | pre <- preloadUnits (homeUnitEnv_units env)] pls') (return pls0) (hsc_HUG hsc_env) -- steps (c), (d) and (e) loadCmdLineLibs' interp hsc_env pls @@ -881,7 +881,13 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded) + do + let groupedLoadedPackageInfos = groupLoadedPackageInfosByParent pkgs_loaded + for_ groupedLoadedPackageInfos $ \(mParent, loaded_pkg_uids) -> do + let unit_env' = case mParent of + Nothing -> unit_env + Just parent -> ue_setActiveUnit parent unit_env + linkDynLib logger tmpfs dflags2 unit_env' objs loaded_pkg_uids -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] @@ -892,6 +898,19 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" + groupOn :: Eq k => (a -> k) -> [a] -> [NE.NonEmpty a] + groupOn f = NE.groupBy ((==) `on2` f) + -- redefine on so we avoid duplicate computation for most values. + where (.*.) `on2` f = \x -> let fx = f x in \y -> fx .*. f y + + groupLoadedPackageInfosByParent :: PkgsLoaded -> [(Maybe UnitId, [UnitId])] + groupLoadedPackageInfosByParent pkgs = + map (\l -> (loaded_pkg_parent (NE.head l), NE.toList $ NE.map loaded_pkg_uid l)) + $ groupOn loaded_pkg_parent + $ sortOn loaded_pkg_parent + $ eltsUDFM pkgs + + rmDupLinkables :: LinkableSet -- Already loaded -> [Linkable] -- New linkables -> (LinkableSet, -- New loaded set (including new ones) @@ -1102,36 +1121,39 @@ loadPackages interp hsc_env new_pkgs = do -- a lock. initLoaderState interp hsc_env modifyLoaderState_ interp $ \pls -> - loadPackages' interp hsc_env new_pkgs pls + loadPackages' interp hsc_env [LibraryUnits {home_unit = hscActiveUnitId hsc_env, library_unit} | library_unit <- new_pkgs] pls -loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState -loadPackages' interp hsc_env new_pks pls = do +loadPackages' :: Interp -> HscEnv -> [LibraryUnits] -> LoaderState -> IO LoaderState +loadPackages' interp hsc_env0 new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded + link :: PkgsLoaded -> [LibraryUnits] -> IO PkgsLoaded link pkgs new_pkgs = foldM link_one pkgs new_pkgs - link_one pkgs new_pkg - | new_pkg `elemUDFM` pkgs -- Already linked + link_one pkgs (LibraryUnits {home_unit, library_unit}) + | library_unit `elemUDFM` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg + | Just pkg_cfg <- lookupUnitId (hsc_units (hscSetActiveUnitId home_unit hsc_env)) library_unit = do { let deps = unitDepends pkg_cfg -- Link dependents first - ; pkgs' <- link pkgs deps + ; pkgs' <- link pkgs [LibraryUnits {home_unit, library_unit} | library_unit <- deps] + -- Now link the package itself ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } + ; return (addToUDFM pkgs' library_unit (LoadedPkgInfo library_unit (Just home_unit) hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS library_unit))) + where + hsc_env = hscSetActiveUnitId home_unit hsc_env0 loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -204,6 +204,7 @@ type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo data LoadedPkgInfo = LoadedPkgInfo { loaded_pkg_uid :: !UnitId + , loaded_pkg_parent :: !(Maybe UnitId) , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] @@ -212,8 +213,9 @@ data LoadedPkgInfo } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = - vcat [ppr uid + ppr (LoadedPkgInfo uid parent_uid hs_objs non_hs_objs _ trans_deps) = + vcat [ ppr uid + , ppr parent_uid , ppr hs_objs , ppr non_hs_objs , ppr trans_deps ] ===================================== testsuite/tests/bytecode/T25090/all.T ===================================== @@ -1,51 +1,51 @@ -# This test compiles the boot file separately from its source file, which causes -# a debug assertion warning. -# Since this appears to be intentional according to the Note [Loading your own hi-boot file], -# the warning is added to the expected stderr for debugged builds. -def test_T25090(name): - assert_warn_spec = {'stderr': 'T25090-debug.stderr'} - extra_specs = assert_warn_spec if name == 'T25090a' and compiler_debugged() else {} - return test(name, - [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']), - req_th, - js_skip, - use_specs(dict(stdout = 'T25090.stdout', **extra_specs)), - ], - makefile_test, - []) - -test_T25090('T25090a') -test_T25090('T25090b') - -def test_pkg(name, files = []): - test( - name, - [ - extra_files([ - 'PkgBytecode.hs', - 'Local.hs', - 'Dep.hs', - 'DepApi.hs', - 'Num.hs', - 'Num.hs-boot', - 'dep.conf', - 'prep.bash', - 'run.bash', - ] + files), - req_th, - js_skip, - windows_skip, - use_specs({'stdout': 'PkgBytecode.stdout'}), - ], - makefile_test, - [], - ) - -test_pkg('T25090_pkg') -test_pkg('T25090_pkg_empty') -test_pkg('T25090_pkg_nolib') -test_pkg('T25090_pkg_obj_code') -test_pkg('T25090_pkg_multi_unit', ['unit1', 'unit2']) -# TODO this doesn't work, because `locateLib` ignores static archives when the interpreter is dynamic, even though a -# comment says "search for .so libraries _first_" (rather than "only"). -# test_pkg('T25090_pkg_archive') +# # This test compiles the boot file separately from its source file, which causes +# # a debug assertion warning. +# # Since this appears to be intentional according to the Note [Loading your own hi-boot file], +# # the warning is added to the expected stderr for debugged builds. +# def test_T25090(name): +# assert_warn_spec = {'stderr': 'T25090-debug.stderr'} +# extra_specs = assert_warn_spec if name == 'T25090a' and compiler_debugged() else {} +# return test(name, +# [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']), +# req_th, +# js_skip, +# use_specs(dict(stdout = 'T25090.stdout', **extra_specs)), +# ], +# makefile_test, +# []) +# +# test_T25090('T25090a') +# test_T25090('T25090b') +# +# def test_pkg(name, files = []): +# test( +# name, +# [ +# extra_files([ +# 'PkgBytecode.hs', +# 'Local.hs', +# 'Dep.hs', +# 'DepApi.hs', +# 'Num.hs', +# 'Num.hs-boot', +# 'dep.conf', +# 'prep.bash', +# 'run.bash', +# ] + files), +# req_th, +# js_skip, +# windows_skip, +# use_specs({'stdout': 'PkgBytecode.stdout'}), +# ], +# makefile_test, +# [], +# ) +# +# test_pkg('T25090_pkg') +# test_pkg('T25090_pkg_empty') +# test_pkg('T25090_pkg_nolib') +# test_pkg('T25090_pkg_obj_code') +# test_pkg('T25090_pkg_multi_unit', ['unit1', 'unit2']) +# # TODO this doesn't work, because `locateLib` ignores static archives when the interpreter is dynamic, even though a +# # comment says "search for .so libraries _first_" (rather than "only"). +# # test_pkg('T25090_pkg_archive') ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepA/A.hs ===================================== @@ -0,0 +1,9 @@ + +module A (a) where + +import Dep1 (d) + +import Data.Text qualified as Text + +a :: Int +a = d ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepC/C.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +module C where + +import Language.Haskell.TH.Syntax (lift) +import A (a) + +c :: Int +c = $(lift a) + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/Makefile ===================================== @@ -0,0 +1,28 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +test-bc: prepare + '$(TEST_HC)' -fprefer-byte-code -fbyte-code-and-object-code -dynamic -unit @unita -unit @unitc + +test-obj: prepare + '$(TEST_HC)' -dynamic -unit @unita -unit @unitc + +# make test should not yield +# <no location info>: error: unknown unit: dep1-1 + +prepare: clean + '$(TEST_HC)' -c ./dep1/Dep1.hs -this-unit-id dep1-1 -dynamic -no-link -fPIC -osuf dyn_o -hisuf dyn_hi -o ./dep1/Dep1.dyn_o + '$(TEST_HC)' -shared -dynamic -fPIC -o ./dep1/libHSdep1-1-ghc9.10.1.so ./dep1/Dep1.dyn_o + '$(GHC_PKG)' --package-db dep1 recache + +clean: + $(RM) **/*.dyn_hi + $(RM) **/*.dyn_o + $(RM) **/*.hi + $(RM) **/*.o + $(RM) **/*.so + $(RM) dep1/package.cache + $(RM) dep1/package.cache.lock + $(RM) libHSdep1-1-ghc9.10.1.so + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/all.T ===================================== @@ -0,0 +1,9 @@ +# We just want compilation to succeed here +test('mhu-transitive-th-deps-bc', + [ extra_files(["dep1", "DepA", "DepC", "unita","unitc"]) + ], makefile_test, ['test-bc']) + +test('mhu-transitive-th-deps-obj', + [ extra_files(["dep1", "DepA", "DepC", "unita","unitc"]) + ], makefile_test, ['test-obj']) + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/Dep1.hs ===================================== @@ -0,0 +1,6 @@ + +module Dep1 (d) where + +d :: Int +d = 42 + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/dep1.conf ===================================== @@ -0,0 +1,9 @@ +name: dep1 +version: 1 +visibility: public +id: dep1-1 +exposed: False +exposed-modules: Dep1 +import-dirs: ${pkgroot}/dep1 +library-dirs: ${pkgroot}/dep1 +hs-libraries: HSdep1-1 ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-bc.stdout ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling A ( DepA/A.hs, DepA/A.o, interpreted )[unita] +[2 of 2] Compiling C ( DepC/C.hs, DepC/C.o, interpreted )[unitc] ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-obj.stdout ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling A ( DepA/A.hs, DepA/A.o )[unita] +[2 of 2] Compiling C ( DepC/C.hs, DepC/C.o )[unitc] ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unita ===================================== @@ -0,0 +1 @@ +-iDepA -this-unit-id unita -hide-all-packages -package base -package text -package-db dep1 -package dep1 A ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unitc ===================================== @@ -0,0 +1 @@ +-iDepC -this-unit-id unitc -hide-all-packages -package-id unita -package base -package template-haskell C View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8323b4b98a498628021d037253034f6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8323b4b98a498628021d037253034f6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/subordinate-export-namespaces] 11 commits: Fix stack decoding when using profiled runtime
by Vladislav Zavialov (＠int-index) 29 Oct '25

29 Oct '25

Vladislav Zavialov pushed to branch wip/int-index/subordinate-export-namespaces at Glasgow Haskell Compiler / GHC Commits: 38d65187 by Matthew Pickering at 2025-10-21T13:12:20+01:00 Fix stack decoding when using profiled runtime There are three fixes in this commit. * We need to replicate the `InfoTable` and `InfoTableProf` approach for the other stack constants (see the new Stack.ConstantsProf file). * Then we need to appropiately import the profiled or non-profiled versions. * Finally, there was an incorrect addition in `stackFrameSize`. We need to cast after performing addition on words. Fixes #26507 - - - - - 17231bfb by fendor at 2025-10-21T13:12:20+01:00 Add regression test for #26507 - - - - - 4f5bf93b by Simon Peyton Jones at 2025-10-25T04:05:34-04:00 Postscript to fix for #26255 This MR has comments only - - - - - 6ef22fa0 by IC Rainbow at 2025-10-26T18:23:01-04:00 Add SIMD primops for bitwise logical operations This adds 128-bit wide and/or/xor instructions for X86 NCG, with both SSE and AVX encodings. ``` andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -- andps / vandps andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -- andpd / vandpd andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16# -- pand / vpand ``` The new primops are available on ARM when using LLVM backend. Tests added: - simd015 (floats and doubles) - simd016 (integers) - simd017 (words) Fixes #26417 - - - - - fbdc623a by sheaf at 2025-10-26T18:23:52-04:00 Add hints for unsolved HasField constraints This commit adds hints and explanations for unsolved 'HasField' constraints. GHC will now provide additional explanations for an unsolved constraint of the form 'HasField fld_name rec_ty fld_ty'; the details are laid out in Note [Error messages for unsolved HasField constraints], but briefly: 1. Provide similar name suggestions (e.g. mis-spelled field name) and import suggestions (record field not in scope). These result in actionable 'GhcHints', which is helpful to provide code actions in HLS. 2. Explain why GHC did not solve the constraint, e.g.: - 'fld_name' is not a string literal (e.g. a type variable) - 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'. - 'fld_ty' contains existentials variables or foralls. - The record field is a pattern synonym field (GHC does not generate HasField instances for those). - 'HasField' is a custom 'TyCon', not actually the built-in 'HasField' typeclass from 'GHC.Records'. On the way, we slightly refactor the mechanisms for import suggestions in GHC.Rename.Unbound. This is to account for the fact that, for 'HasField', we don't care whether the field is imported qualified or unqualified. 'importSuggestions' was refactored, we now have 'sameQualImportSuggestions' and 'anyQualImportSuggestions'. Fixes #18776 #22382 #26480 - - - - - 99d5707f by sheaf at 2025-10-26T18:23:52-04:00 Rename PatSyn MatchContext to PatSynCtx to avoid punning - - - - - 5dc2e9ea by Julian Ospald at 2025-10-27T18:17:23-04:00 Skip uniques test if sources are not available - - - - - 544b9ec9 by Vladislav Zavialov at 2025-10-27T18:18:06-04:00 Re-export GHC.Hs.Basic from GHC.Hs Clean up some import sections in GHC by re-exporting GHC.Hs.Basic from GHC.Hs. - - - - - 643ce801 by Julian Ospald at 2025-10-28T18:18:55-04:00 rts: remove unneccesary cabal flags We perform those checks via proper autoconf macros instead that do the right thing and then add those libs to the rts buildinfo. - - - - - d69ea8fe by Vladislav Zavialov at 2025-10-28T18:19:37-04:00 Test case for #17705 Starting with GHC 9.12 (the first release to include 5745dbd3), all examples in this ticket are handled as expected. - - - - - 5120a24a by Vladislav Zavialov at 2025-10-29T20:54:07+03:00 Fix namespace specifiers in subordinate exports (#12488) This patch fixes an oversight in the `lookupChildrenExport` function that caused explicit namespace specifiers of subordinate export items to be ignored: module M (T (type A)) where -- should be rejected data T = A Based on the `IEWrappedName` data type, there are 5 cases to consider: 1. Unadorned name: P(X) 2. Named default: P(default X) 3. Pattern synonym: P(pattern X) 4. Type name: P(type X) 5. Data name: P(data X) Case 1 is already handled correctly; cases 2 and 3 are parse errors; and it is cases 4 and 5 that we are concerned with in this patch. Following the precedent established in `LookupExactName`, we introduce a boolean flag in `LookupChildren` to control whether to look up in all namespaces or in a specific one. If an export item is accompanied by an explicit namespace specifier `type` or `data`, we restrict the lookup in `lookupGRE` to a specific namespace. The newly introduced diagnostic `TcRnExportedSubordinateNotFound` provides error messages and suggestions more tailored to this context than the previously used `reportUnboundName`. - - - - - 117 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/Core/ConLike.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/Language/Haskell/Syntax/Expr.hs - docs/users_guide/9.16.1-notes.rst - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-experimental/CHANGELOG.md - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - + libraries/ghc-internal/tests/backtraces/T26507.stderr - libraries/ghc-internal/tests/backtraces/all.T - libraries/ghc-internal/tests/stack-annotation/all.T - libraries/ghc-prim/changelog.md - m4/fp_check_pthreads.m4 - rts/configure.ac - + rts/rts.buildinfo.in - rts/rts.cabal - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/linters/all.T - testsuite/tests/module/mod4.stderr - + testsuite/tests/overloadedrecflds/should_fail/T26480.hs - + testsuite/tests/overloadedrecflds/should_fail/T26480.stderr - + testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs - + testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs - + testsuite/tests/overloadedrecflds/should_fail/T26480b.hs - + testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/overloadedrecflds/should_fail/all.T - testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr - testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - + testsuite/tests/parser/should_fail/T12488c.hs - + testsuite/tests/parser/should_fail/T12488c.stderr - + testsuite/tests/parser/should_fail/T12488d.hs - + testsuite/tests/parser/should_fail/T12488d.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/rename/should_compile/T12488b.hs - + testsuite/tests/rename/should_compile/T12488f.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T12488a.hs - + testsuite/tests/rename/should_fail/T12488a.stderr - + testsuite/tests/rename/should_fail/T12488a_foo.hs - + testsuite/tests/rename/should_fail/T12488a_foo.stderr - + testsuite/tests/rename/should_fail/T12488e.hs - + testsuite/tests/rename/should_fail/T12488e.stderr - + testsuite/tests/rename/should_fail/T12488g.hs - + testsuite/tests/rename/should_fail/T12488g.stderr - testsuite/tests/rename/should_fail/T19843h.stderr - testsuite/tests/rename/should_fail/T25899e2.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simd/should_run/simd015.hs - + testsuite/tests/simd/should_run/simd015.stdout - + testsuite/tests/simd/should_run/simd016.hs - + testsuite/tests/simd/should_run/simd016.stdout - + testsuite/tests/simd/should_run/simd017.hs - + testsuite/tests/simd/should_run/simd017.stdout - + testsuite/tests/typecheck/should_compile/T17705.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dfb2f9d1ff507ff37410de3adc8197… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dfb2f9d1ff507ff37410de3adc8197… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/subordinate-export-namespaces] Better error messages and hints
by Vladislav Zavialov (＠int-index) 29 Oct '25

29 Oct '25

Vladislav Zavialov pushed to branch wip/int-index/subordinate-export-namespaces at Glasgow Haskell Compiler / GHC Commits: dfb2f9d1 by Vladislav Zavialov at 2025-10-29T16:03:47+03:00 Better error messages and hints - - - - - 20 changed files: - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - testsuite/tests/module/mod4.stderr - testsuite/tests/rename/should_compile/T12488b.hs - + testsuite/tests/rename/should_compile/T12488f.hs - testsuite/tests/rename/should_compile/all.T - testsuite/tests/rename/should_fail/T12488a.hs - testsuite/tests/rename/should_fail/T12488a.stderr - testsuite/tests/rename/should_fail/T12488a_foo.stderr - testsuite/tests/rename/should_fail/T12488e.hs - testsuite/tests/rename/should_fail/T12488e.stderr - + testsuite/tests/rename/should_fail/T12488g.hs - + testsuite/tests/rename/should_fail/T12488g.stderr - testsuite/tests/rename/should_fail/T25899e2.stderr - testsuite/tests/rename/should_fail/all.T Changes: ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -23,6 +23,7 @@ module GHC.Rename.Names ( checkConName, mkChildEnv, findChildren, + mkBadExportSubordinate, findImportUsage, getMinimalImports, printMinimalImports, @@ -1423,6 +1424,15 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) where name = greName gre +-- | Assuming a subordinate item could not be found, do another lookup for a +-- more specific error message. +mkBadExportSubordinate :: [GlobalRdrElt] -> LIEWrappedName GhcPs -> BadExportSubordinate +mkBadExportSubordinate child_gres n = + case lookupChildren child_gres [n] of + (LookupChildNonType {lce_nontype_item = g} : _, _) -> BadExportSubordinateNonType g + (LookupChildNonData {lce_nondata_item = g} : _, _) -> BadExportSubordinateNonData g + _ -> BadExportSubordinateNotFound n + type IELookupM = MaybeErr IELookupError data IELookupWarning ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -674,6 +674,43 @@ instance Diagnostic TcRnMessage where what_is = pp_category ty_thing thing = ppr $ nameOccName child parents = map ppr parent_names + TcRnExportedSubordinateNotFound parent_gre k _ -> + mkSimpleDecorated $ + case k of + BadExportSubordinateNotFound wname -> + let child_name = lieWrappedName wname + child_name_fs = occNameFS (rdrNameOcc child_name) + suggest_patsyn = allow_patsyn && could_be_patsyn + could_be_patsyn = + case unLoc wname of + IEName{} -> isLexCon child_name_fs + IEData{} -> isLexCon child_name_fs + IEPattern{} -> True + IEType{} -> False + IEDefault{} -> False + basic_msg = + what_parent <+> quotes (ppr parent_name) + <+> "does not define a child named" <+> quotes (ppr child_name) + patsyn_msg = + text "nor is there a pattern synonym of that name in scope" + combined_msg + | suggest_patsyn = basic_msg <> comma $$ patsyn_msg <> dot + | otherwise = basic_msg <> dot + in combined_msg + BadExportSubordinateNonType gre -> + let child_name = greName gre + in what_parent <+> quotes (ppr parent_name) <+> "defines a child named" <+> quotes (ppr child_name) <> comma + $$ text "but it is not in the type namespace." + BadExportSubordinateNonData gre -> + let child_name = greName gre + in what_parent <+> quotes (ppr parent_name) <+> "defines a child named" <+> quotes (ppr child_name) <> comma + $$ text "but it is not in the data namespace." + where + parent_name = greName parent_gre + (what_parent, allow_patsyn) = case greInfo parent_gre of + IAmTyCon ClassFlavour -> (text "The class", False) + IAmTyCon _ -> (text "The data type", True) + _ -> (text "The item", False) TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2 -> mkSimpleDecorated $ vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon @@ -2203,6 +2240,8 @@ instance Diagnostic TcRnMessage where -> WarningWithFlag Opt_WarnDuplicateExports TcRnExportedParentChildMismatch{} -> ErrorWithoutFlag + TcRnExportedSubordinateNotFound{} + -> ErrorWithoutFlag TcRnConflictingExports{} -> ErrorWithoutFlag TcRnDuplicateFieldExport {} @@ -2874,6 +2913,13 @@ instance Diagnostic TcRnMessage where -> noHints TcRnExportedParentChildMismatch{} -> noHints + TcRnExportedSubordinateNotFound _ k similar_names + -> ns_spec_hints ++ similar_names + where + ns_spec_hints = case k of + BadExportSubordinateNotFound{} -> noHints + BadExportSubordinateNonType{} -> [SuggestChangeExportItem ExportItemRemoveSubordinateType] + BadExportSubordinateNonData{} -> [SuggestChangeExportItem ExportItemRemoveSubordinateData] TcRnConflictingExports{} -> noHints TcRnDuplicateFieldExport {} ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -83,7 +83,6 @@ module GHC.Tc.Errors.Types ( , Subordinate(..), pprSubordinate , ImportError(..) , WhatLooking(..) - , lookingForSubordinate , HoleError(..) , CoercibleMsg(..) , PotentialInstances(..) @@ -114,6 +113,7 @@ module GHC.Tc.Errors.Types ( , HsTyVarBndrExistentialFlag(..) , TySynCycleTyCons , BadImportKind(..) + , BadExportSubordinate(..) , DodgyImportsReason (..) , ImportLookupExtensions (..) , ImportLookupReason (..) @@ -1663,6 +1663,26 @@ data TcRnMessage where -> Name -- ^ child -> [Name] -> TcRnMessage + {-| TcRnExportedSubordinateNotFound is an error that occurs when the name of a + subordinate export item is not in scope. + + Example: + module M (T(X)) where -- X is not in scope + data T = Y + + Test cases: module/mod4 + rename/should_fail/T12488a + rename/should_fail/T12488a_foo + rename/should_fail/T12488e + rename/should_fail/T12488g + rename/should_fail/T25899e2 + -} + TcRnExportedSubordinateNotFound + :: GlobalRdrElt -- ^ parent + -> BadExportSubordinate + -> [GhcHint] -- ^ similar name suggestions + -> TcRnMessage + {-| TcRnConflictingExports is an error that occurs when different identifiers that have the same name are being exported by a module. @@ -5822,6 +5842,11 @@ data BadImportKind | BadImportAvailVar deriving Generic +data BadExportSubordinate + = BadExportSubordinateNotFound !(LIEWrappedName GhcPs) + | BadExportSubordinateNonType !GlobalRdrElt + | BadExportSubordinateNonData !GlobalRdrElt + {- Note [Reasons for BadImportAvailTyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BadImportAvailTyCon means a name is available in the TcCls namespace @@ -6016,15 +6041,6 @@ data WhatLooking = WL_Anything -- is no point in suggesting alternative spellings deriving (Eq, Show) --- | In what namespaces should we look for a subordinate --- of the given 'GlobalRdrElt'. -lookingForSubordinate :: GlobalRdrElt -> WhatLooking -lookingForSubordinate parent_gre = - case greInfo parent_gre of - IAmTyCon ClassFlavour - -> WL_TyCon_or_TermVar - _ -> WL_Term - -- | This datatype collates instances that match or unifier, -- in order to report an error message for an unsolved typeclass constraint. data PotentialInstances ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Rename.Doc import GHC.Rename.Module import GHC.Rename.Names import GHC.Rename.Env -import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Unbound ( mkUnboundNameRdr ) import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported @@ -30,6 +30,7 @@ import GHC.Unit.Module.Warnings import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc (fuzzyLookup) import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Data.Maybe @@ -49,6 +50,7 @@ import GHC.Types.SourceFile import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Reader +import GHC.Types.Hint import Control.Arrow ( first ) import Control.Monad ( when ) @@ -589,8 +591,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs] -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt]) lookup_ie_kids_with gre sub_rdrs = - do { kids <- lookupChildrenExport gre sub_rdrs - ; return (map fst kids, map snd kids) } + do { let child_gres = findChildren kids_env (greName gre) + ; kids <- lookupChildrenExport gre child_gres sub_rdrs + ; return (unzip kids) } lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt -> RnM [GlobalRdrElt] @@ -781,9 +784,10 @@ If the module has NO main function: lookupChildrenExport :: GlobalRdrElt + -> [GlobalRdrElt] -> [LIEWrappedName GhcPs] -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) -lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items +lookupChildrenExport parent_gre child_gres rdr_items = mapAndReportM doOne rdr_items where spec_parent = greName parent_gre -- Process an individual child @@ -794,23 +798,20 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items let all_ns = case unLoc n of IEName{} -> True -- Ignore the namespace iff the name is unadorned _ -> False - let bareName = (ieWrappedName . unLoc) n + let bareName = lieWrappedName n -- Do not report export list declaration deprecations name <- lookupSubBndrOcc_helper False all_ns ExportDeprecationWarnings (ParentGRE spec_parent (greInfo parent_gre)) bareName traceRn "lookupChildrenExport" (ppr name) - -- Default to data namespace for slightly better error messages - let unboundName :: RdrName - unboundName - | all_ns = fromMaybe bareName (demoteRdrName bareName) - | otherwise = bareName case name of NameNotFound -> - do { ub <- reportUnboundName (lookingForSubordinate parent_gre) unboundName - ; let l = getLoc n - gre = mkLocalGRE UnboundGRE NoParent ub - ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} + do { let err = mkBadExportSubordinate child_gres n + similar_names = subordinateExportSimilarNames bareName child_gres + ; addDiagnosticTc (TcRnExportedSubordinateNotFound parent_gre err similar_names) + ; let ub = mkUnboundNameRdr bareName + ; let gre = mkLocalGRE UnboundGRE NoParent ub + ; return (replaceLWrappedName n ub, gre)} FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> do { checkPatSynParent spec_parent par child_nm ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) @@ -818,6 +819,22 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items } IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs +subordinateExportSimilarNames :: RdrName -> [GlobalRdrElt] -> [GhcHint] +subordinateExportSimilarNames rdr_name child_gres = + -- At the moment, we only suggest other children of the same parent. + -- One possible improvement would be to suggest bundling pattern synonyms with + -- data types, but not with classes or type data. + case NE.nonEmpty similar_names of + Nothing -> [] + Just nms -> [SuggestSimilarNames rdr_name (fmap SimilarName nms)] + where + occ_name = rdrNameOcc rdr_name + similar_names = + fuzzyLookup (occNameString occ_name) + [(occNameString child_occ_name, greName gre) + | gre <- child_gres + , let child_occ_name = greOccName gre + , occNameFS occ_name /= occNameFS child_occ_name ] -- Note [Typing Pattern Synonym Exports] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -510,6 +510,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnDuplicateExport" = 47854 GhcDiagnosticCode "TcRnDuplicateNamedDefaultExport" = 31584 GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 + GhcDiagnosticCode "TcRnExportedSubordinateNotFound" = 11592 GhcDiagnosticCode "TcRnConflictingExports" = 69158 GhcDiagnosticCode "TcRnDuplicateFieldExport" = 97219 GhcDiagnosticCode "TcRnAmbiguousFieldInUpdate" = 56428 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -7,6 +7,7 @@ module GHC.Types.Hint ( , LanguageExtensionHint(..) , ImportItemSuggestion(..) , ImportSuggestion(..) + , ExportItemSuggestion(..) , HowInScope(..) , SimilarName(..) , StarIsType(..) @@ -411,6 +412,12 @@ data GhcHint -} | ImportSuggestion OccName ImportSuggestion + {-| Suggest to change an export item, e.g. to remove a namespace specifier. + + Test cases: T12488a, T12488a_foo, T12488e, T12488g, T25899e2 + -} + | SuggestChangeExportItem ExportItemSuggestion + {-| Found a pragma in the body of a module, suggest placing it in the header. -} | SuggestPlacePragmaInHeader @@ -551,6 +558,11 @@ data ImportItemSuggestion = -- Why no 'ImportItemAddData'? Because the suggestion to add 'data' is -- represented by the 'ImportDataCon' constructor of 'ImportSuggestion'. +-- | Suggest to change an export item. +data ExportItemSuggestion = + ExportItemRemoveSubordinateType + | ExportItemRemoveSubordinateData + -- | Suggest how to fix an import. data ImportSuggestion -- | Some module exports what we want, but we aren't explicitly importing it. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -210,6 +210,10 @@ instance Outputable GhcHint where <+> pprQuotedList parents ImportSuggestion occ_name import_suggestion -> pprImportSuggestion occ_name import_suggestion + SuggestChangeExportItem export_item_suggestion + -> case export_item_suggestion of + ExportItemRemoveSubordinateType -> text "Remove the" <+> quotes (text "type") <+> text "keyword" + ExportItemRemoveSubordinateData -> text "Remove the" <+> quotes (text "data") <+> text "keyword" SuggestPlacePragmaInHeader -> text "Perhaps you meant to place it in the module header?" $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword" ===================================== testsuite/tests/module/mod4.stderr ===================================== @@ -1,5 +1,6 @@ - -mod4.hs:2:10: error: [GHC-76037] - • Not in scope: data constructor ‘K2’ +mod4.hs:2:10: error: [GHC-11592] + • The data type ‘T’ does not define a child named ‘K2’, + nor is there a pattern synonym of that name in scope. • In the export: T(K1, K2) - Suggested fix: Perhaps use ‘K1’ (line 3) + Suggested fix: Perhaps use ‘K1’ (Defined at mod4.hs:3:10) + ===================================== testsuite/tests/rename/should_compile/T12488b.hs ===================================== @@ -1,4 +1,24 @@ {-# LANGUAGE ExplicitNamespaces #-} -module T12488b ( T (data A) ) where +{-# LANGUAGE TypeFamilies #-} -data T = A +module T12488b + ( T ( data A, -- data constructor (alphanumeric name) + data fld, -- record field (alphanumeric name) + data (:!!), -- data constructor (symbolic name) + data (///) -- record field (symbolic name) + ), + C ( type F, -- associated type (alphanumeric name) + data meth, -- class method (alphanumeric name) + type (+++), -- associated type (symbolic name) + data (***) -- class method (symbolic name) + ), + ) where + +data T = A { fld :: Int } + | (:!!) { (///) :: Int -> Int } + +class C a where + type F a + type (+++) a + meth :: a -> a + (***) :: a -> a -> a ===================================== testsuite/tests/rename/should_compile/T12488f.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} + +module T12488f + ( C ( type (+++), -- associated type (symbolic name) + data (++-) -- class method (symbolic name) + ), + ) where + +class C a where + type (+++) a -- exported + type (++-) a -- not exported + (+++) :: a -> a -- not exported + (++-) :: a -> a -- exported ===================================== testsuite/tests/rename/should_compile/all.T ===================================== @@ -246,3 +246,4 @@ test('T25899b', normal, compile, ['']) test('T25899c', [extra_files(['T25899c_helper.hs'])], multimod_compile, ['T25899c', '-v0']) test('T25899d', combined_output, ghci_script, ['T25899d.script']) test('T12488b', normal, compile, ['']) +test('T12488f', normal, compile, ['']) ===================================== testsuite/tests/rename/should_fail/T12488a.hs ===================================== @@ -1,4 +1,9 @@ {-# LANGUAGE ExplicitNamespaces #-} -module T12488a ( T (type A) ) where +module T12488a + ( T (type A) + , (:!) (type (:/)) + ) where data T = A + +data (:!) = (:/) \ No newline at end of file ===================================== testsuite/tests/rename/should_fail/T12488a.stderr ===================================== @@ -1,5 +1,12 @@ -T12488a.hs:2:18: error: [GHC-76037] - • Not in scope: type constructor or class ‘A’ +T12488a.hs:3:5: error: [GHC-11592] + • The data type ‘T’ defines a child named ‘A’, + but it is not in the type namespace. • In the export: T(type A) - Suggested fix: Perhaps use data constructor ‘A’ (line 4) + Suggested fix: Remove the ‘type’ keyword + +T12488a.hs:4:5: error: [GHC-11592] + • The data type ‘:!’ defines a child named ‘:/’, + but it is not in the type namespace. + • In the export: (:!)(type (:/)) + Suggested fix: Remove the ‘type’ keyword ===================================== testsuite/tests/rename/should_fail/T12488a_foo.stderr ===================================== @@ -1,5 +1,6 @@ -T12488a_foo.hs:3:22: error: [GHC-76037] - • Not in scope: type constructor or class ‘A’ +T12488a_foo.hs:3:22: error: [GHC-11592] + • The data type ‘T’ defines a child named ‘A’, + but it is not in the type namespace. • In the export: T(type A) - Suggested fix: Perhaps use data constructor ‘A’ (line 5) + Suggested fix: Remove the ‘type’ keyword ===================================== testsuite/tests/rename/should_fail/T12488e.hs ===================================== @@ -1,6 +1,12 @@ {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE TypeFamilies #-} -module T12488e ( C (data A) ) where +module T12488e + ( C (data A) + , D (data (+++)) + ) where class C a where type A a + +class D a where + type (+++) a \ No newline at end of file ===================================== testsuite/tests/rename/should_fail/T12488e.stderr ===================================== @@ -1,5 +1,12 @@ -T12488e.hs:3:18: error: [GHC-76037] - • Not in scope: data constructor ‘A’ +T12488e.hs:4:5: error: [GHC-11592] + • The class ‘C’ defines a child named ‘A’, + but it is not in the data namespace. • In the export: C(data A) - Suggested fix: Perhaps use type constructor or class ‘A’ (line 6) + Suggested fix: Remove the ‘data’ keyword + +T12488e.hs:5:5: error: [GHC-11592] + • The class ‘D’ defines a child named ‘+++’, + but it is not in the data namespace. + • In the export: D(data (+++)) + Suggested fix: Remove the ‘data’ keyword ===================================== testsuite/tests/rename/should_fail/T12488g.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} +module T12488g + ( C (data (+++), + type (++-)) + ) where + +class C a where + type (+++) a + (++-) :: a -> a ===================================== testsuite/tests/rename/should_fail/T12488g.stderr ===================================== @@ -0,0 +1,16 @@ +T12488g.hs:4:5: error: [GHC-11592] + • The class ‘C’ defines a child named ‘++-’, + but it is not in the type namespace. + • In the export: C(data (+++), type (++-)) + Suggested fixes: + • Remove the ‘type’ keyword + • Perhaps use ‘+++’ (Defined at T12488g.hs:9:3) + +T12488g.hs:4:5: error: [GHC-11592] + • The class ‘C’ defines a child named ‘+++’, + but it is not in the data namespace. + • In the export: C(data (+++), type (++-)) + Suggested fixes: + • Remove the ‘data’ keyword + • Perhaps use ‘++-’ (Defined at T12488g.hs:10:3) + ===================================== testsuite/tests/rename/should_fail/T25899e2.stderr ===================================== @@ -1,4 +1,6 @@ -T25899e2.hs:5:5: error: [GHC-76037] - • Not in scope: data constructor ‘MkT’ +T25899e2.hs:5:5: error: [GHC-11592] + • The data type ‘T’ defines a child named ‘MkT’, + but it is not in the data namespace. • In the export: type T(data MkT) + Suggested fix: Remove the ‘data’ keyword ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -249,3 +249,4 @@ test('T25899f', [extra_files(['T25899f_helper.hs'])], multimod_compile_fail, [' test('T12488a', normal, compile_fail, ['']) test('T12488a_foo', normal, compile_fail, ['']) test('T12488e', normal, compile_fail, ['']) +test('T12488g', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfb2f9d1ff507ff37410de3adc8197f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfb2f9d1ff507ff37410de3adc8197f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/occ_anal_tuning] OccAnal: Be stricter for better compiler perf.
by Andreas Klebinger (＠AndreasK) 29 Oct '25

29 Oct '25

Andreas Klebinger pushed to branch wip/andreask/occ_anal_tuning at Glasgow Haskell Compiler / GHC Commits: 37a44c2c by Andreas Klebinger at 2025-10-29T13:46:48+01:00 OccAnal: Be stricter for better compiler perf. In particular we are now stricter: * When combining usageDetails. * When computing binder info. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. We also force binders we put into the Core AST everywhere now. Failure to do so risks leaking the occ env used to set the binders OccInfo. For T26425 compiler residency went down by a factor of ~10x. Compile time also improved by a factor of ~1.6. ------------------------- Metric Decrease: T18698a T26425 T9233 ------------------------- - - - - - 3 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -9,6 +9,8 @@ -- many /other/ arguments the function has. Inconsistent unboxing is very -- bad for performance, so I increased the limit to allow it to unbox -- consistently. +-- AK: Seems we no longer unbox OccEnv now anyway so it might be redundant. + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -967,6 +969,12 @@ occAnalBind -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds -> WithUsageDetails r -- Of the whole let(rec) +-- AK: While not allocating any less inlining occAnalBind turns calls to the +-- passed functions into known calls with all the benefits that brings. +-- On a version of T26425 with 6k alternatives this improved compile +-- by 10-20% with -O. +{-# INLINE occAnalBind #-} + occAnalBind env lvl ire (Rec pairs) thing_inside combine = addInScopeList env (map fst pairs) $ \env -> let WUD body_uds body' = thing_inside env @@ -984,7 +992,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + rhs_uds = foldl1' orUDs rhs_uds_s -- NB: orUDs. See (W4) of -- Note [Occurrence analysis for join points] -- Now analyse the body, adding the join point @@ -1049,6 +1057,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- Match join arity O from mb_join_arity with manifest join arity M as -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ occAnalLamTail rhs_env rhs final_bndr_with_rules @@ -2054,6 +2063,18 @@ So The Plan is this: was a loop breaker last time round Hence the is_lb field of NodeScore + +Note [Strictness in the occurrence analyser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By carefully making the occurrence analyser strict in some places, we can +dramatically reduce its memory residency. Among other things we: +* Evaluate the result of `tagLamBinder` and friends, so that the binder (or its + OccInfo) does not retain the entire `UsageDetails`. Also use `strictMap` in `tagLamBinders`. +* In `combineUsageDetailsWith`, the fields of the data constructor are strict, and we use + `strictPlusVarEnv` on the maps that are bound to be needed later on to avoid thunks being + stored in the values. + +These measures reduced residency for test T26425 by a factor of at least 5x. -} {- ********************************************************************* @@ -2188,7 +2209,9 @@ occ_anal_lam_tail env expr@(Lam {}) go env rev_bndrs body = addInScope env rev_bndrs $ \env -> let !(WUD usage body') = occ_anal_lam_tail env body - wrap_lam body bndr = Lam (tagLamBinder usage bndr) body + -- See Note [Strictness in the occurrence analyser] + wrap_lam !body !bndr = let !bndr' = tagLamBinder usage bndr + in Lam bndr' body in WUD (usage `addLamCoVarOccs` rev_bndrs) (foldl' wrap_lam body' rev_bndrs) @@ -2541,7 +2564,8 @@ occAnal env (Case scrut bndr ty alts) let alt_env = addBndrSwap scrut' bndr $ setTailCtxt env -- Kill off OccRhs WUD alts_usage alts' = do_alts alt_env alts - tagged_bndr = tagLamBinder alts_usage bndr + !tagged_bndr = tagLamBinder alts_usage bndr + -- See Note [Strictness in the occurrence analyser] in WUD alts_usage (tagged_bndr, alts') total_usage = markAllNonTail scrut_usage `andUDs` alts_usage @@ -2559,11 +2583,13 @@ occAnal env (Case scrut bndr ty alts) do_alt !env (Alt con bndrs rhs) = addInScopeList env bndrs $ \ env -> let WUD rhs_usage rhs' = occAnal env rhs - tagged_bndrs = tagLamBinders rhs_usage bndrs + !tagged_bndrs = tagLamBinders rhs_usage bndrs + -- See Note [Strictness in the occurrence analyser] in -- See Note [Binders in case alternatives] WUD rhs_usage (Alt con tagged_bndrs rhs') occAnal env (Let bind body) + -- TODO: Would be nice to use a strict version of mkLets here = occAnalBind env NotTopLevel noImpRuleEdges bind (\env -> occAnal env body) mkLets @@ -2644,10 +2670,12 @@ occAnalApp !env (Var fun, args, ticks) | fun `hasKey` runRWKey , [t1, t2, arg] <- args , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg - = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] + in WUD usage app_out occAnalApp env (Var fun_id, args, ticks) - = WUD all_uds (mkTicks ticks app') + = let app_out = mkTicks ticks app' + in WUD all_uds app_out where -- Lots of banged bindings: this is a very heavily bit of code, -- so it pays not to make lots of thunks here, all of which @@ -2692,8 +2720,9 @@ occAnalApp env (Var fun_id, args, ticks) -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) - = WUD (markAllNonTail (fun_uds `andUDs` args_uds)) - (mkTicks ticks app') + = let app_out = mkTicks ticks app' + in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out + where !(WUD args_uds app') = occAnalArgs env fun' args [] !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun @@ -3650,8 +3679,8 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +andUDs:: UsageDetails -> UsageDetails -> UsageDetails +orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc @@ -3766,10 +3795,13 @@ combineUsageDetailsWith plus_occ_info | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 + -- See Note [Strictness in the occurrence analyser] + -- Using strictPlusVarEnv here speeds up the test T26425 by about 10% by avoiding + -- intermediate thunks. + = UD { ud_env = strictPlusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = strictPlusVarEnv z_many1 z_many2 , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + , ud_z_tail = strictPlusVarEnv z_tail1 z_tail2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3847,7 +3879,8 @@ tagLamBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> [IdWithOccInfo] -- Tagged binders tagLamBinders usage binders - = map (tagLamBinder usage) binders + -- See Note [Strictness in the occurrence analyser] + = strictMap (tagLamBinder usage) binders tagLamBinder :: UsageDetails -- Of scope -> Id -- Binder @@ -3856,6 +3889,7 @@ tagLamBinder :: UsageDetails -- Of scope -- No-op on TyVars -- A lambda binder never has an unfolding, so no need to look for that tagLamBinder usage bndr + -- See Note [Strictness in the occurrence analyser] = setBinderOcc (markNonTail occ) bndr -- markNonTail: don't try to make an argument into a join point where ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -51,7 +51,9 @@ module GHC.Types.Unique.FM ( delListFromUFM, delListFromUFM_Directly, plusUFM, + strictPlusUFM, plusUFM_C, + strictPlusUFM_C, plusUFM_CD, plusUFM_CD2, mergeUFM, @@ -261,16 +263,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) --- Bindings in right argument shadow those in the left +-- | Bindings in right argument shadow those in the left. +-- +-- Unlike containers this union is right-biased for historic reasons. plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt --- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. +-- | Right biased +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x) + plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y) + -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of ===================================== compiler/GHC/Types/Var/Env.hs ===================================== @@ -12,7 +12,8 @@ module GHC.Types.Var.Env ( elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C, + plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, @@ -511,6 +512,7 @@ extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a varEnvDomain :: VarEnv elt -> UnVarSet @@ -522,6 +524,7 @@ delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b @@ -548,6 +551,7 @@ extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C +strictPlusVarEnv_C = strictPlusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM @@ -556,6 +560,7 @@ delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM +strictPlusVarEnv = strictPlusUFM plusVarEnvList = plusUFMList -- lookupVarEnv is very hot (in part due to being called by substTyVar), -- if it's not inlined than the mere allocation of the Just constructor causes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37a44c2cba90054279641549cb4dae8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37a44c2cba90054279641549cb4dae8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/occ_anal_tuning] OccAnal: Be stricter for better compiler perf.
by Andreas Klebinger (＠AndreasK) 29 Oct '25

29 Oct '25

Andreas Klebinger pushed to branch wip/andreask/occ_anal_tuning at Glasgow Haskell Compiler / GHC Commits: 98918ebc by Andreas Klebinger at 2025-10-29T13:41:29+01:00 OccAnal: Be stricter for better compiler perf. In particular we are now stricter: * When combining usageDetails. * When computing binder info. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. We also force binders we put into the Core AST everywhere now. Failure to do so risks leaking the occ env used to set the binders OccInfo. For T26425 compiler residency went down by a factor of ~10x. Compile time also improved by a factor of ~1.6. ------------------------- Metric Decrease: T18698a T26425 T9233 ------------------------- - - - - - 3 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -9,6 +9,8 @@ -- many /other/ arguments the function has. Inconsistent unboxing is very -- bad for performance, so I increased the limit to allow it to unbox -- consistently. +-- AK: Seems we no longer unbox OccEnv now anyway so it might be redundant. + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -967,6 +969,11 @@ occAnalBind -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds -> WithUsageDetails r -- Of the whole let(rec) +-- While not allocating any less inlining occAnalBind turns calls to the passed functions +-- into known calls. One might assume this doesn't matter, but for let heavy +-- code I observed speed ups as big as 10-20%! +{-# INLINE occAnalBind #-} + occAnalBind env lvl ire (Rec pairs) thing_inside combine = addInScopeList env (map fst pairs) $ \env -> let WUD body_uds body' = thing_inside env @@ -984,7 +991,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + rhs_uds = foldl1' orUDs rhs_uds_s -- NB: orUDs. See (W4) of -- Note [Occurrence analysis for join points] -- Now analyse the body, adding the join point @@ -1049,6 +1056,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- Match join arity O from mb_join_arity with manifest join arity M as -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ occAnalLamTail rhs_env rhs final_bndr_with_rules @@ -2188,7 +2196,8 @@ occ_anal_lam_tail env expr@(Lam {}) go env rev_bndrs body = addInScope env rev_bndrs $ \env -> let !(WUD usage body') = occ_anal_lam_tail env body - wrap_lam body bndr = Lam (tagLamBinder usage bndr) body + wrap_lam !body !bndr = let !bndr' = tagLamBinder usage bndr + in Lam bndr' body in WUD (usage `addLamCoVarOccs` rev_bndrs) (foldl' wrap_lam body' rev_bndrs) @@ -2541,7 +2550,7 @@ occAnal env (Case scrut bndr ty alts) let alt_env = addBndrSwap scrut' bndr $ setTailCtxt env -- Kill off OccRhs WUD alts_usage alts' = do_alts alt_env alts - tagged_bndr = tagLamBinder alts_usage bndr + !tagged_bndr = tagLamBinder alts_usage bndr in WUD alts_usage (tagged_bndr, alts') total_usage = markAllNonTail scrut_usage `andUDs` alts_usage @@ -2559,11 +2568,12 @@ occAnal env (Case scrut bndr ty alts) do_alt !env (Alt con bndrs rhs) = addInScopeList env bndrs $ \ env -> let WUD rhs_usage rhs' = occAnal env rhs - tagged_bndrs = tagLamBinders rhs_usage bndrs + !tagged_bndrs = tagLamBinders rhs_usage bndrs in -- See Note [Binders in case alternatives] WUD rhs_usage (Alt con tagged_bndrs rhs') occAnal env (Let bind body) + -- TODO: Would be nice to use a strict version of mkLets here = occAnalBind env NotTopLevel noImpRuleEdges bind (\env -> occAnal env body) mkLets @@ -2644,10 +2654,12 @@ occAnalApp !env (Var fun, args, ticks) | fun `hasKey` runRWKey , [t1, t2, arg] <- args , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg - = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + = let app_out = (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + in WUD usage app_out occAnalApp env (Var fun_id, args, ticks) - = WUD all_uds (mkTicks ticks app') + = let app_out = (mkTicks ticks app') + in WUD all_uds app_out where -- Lots of banged bindings: this is a very heavily bit of code, -- so it pays not to make lots of thunks here, all of which @@ -2692,8 +2704,9 @@ occAnalApp env (Var fun_id, args, ticks) -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) - = WUD (markAllNonTail (fun_uds `andUDs` args_uds)) - (mkTicks ticks app') + = let app_out = (mkTicks ticks app') + in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out + where !(WUD args_uds app') = occAnalArgs env fun' args [] !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun @@ -3650,8 +3663,8 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +andUDs:: UsageDetails -> UsageDetails -> UsageDetails +orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc @@ -3766,10 +3779,12 @@ combineUsageDetailsWith plus_occ_info | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 + -- Using strictPlusVarEnv here speeds up the test T26425 by about 10% by avoiding + -- intermediate thunks. + = UD { ud_env = strictPlusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = strictPlusVarEnv z_many1 z_many2 , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + , ud_z_tail = strictPlusVarEnv z_tail1 z_tail2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3847,7 +3862,7 @@ tagLamBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> [IdWithOccInfo] -- Tagged binders tagLamBinders usage binders - = map (tagLamBinder usage) binders + = strictMap (tagLamBinder usage) binders tagLamBinder :: UsageDetails -- Of scope -> Id -- Binder ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -51,7 +51,9 @@ module GHC.Types.Unique.FM ( delListFromUFM, delListFromUFM_Directly, plusUFM, + strictPlusUFM, plusUFM_C, + strictPlusUFM_C, plusUFM_CD, plusUFM_CD2, mergeUFM, @@ -261,16 +263,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) --- Bindings in right argument shadow those in the left +-- | Bindings in right argument shadow those in the left. +-- +-- Unlike containers this union is right-biased for historic reasons. plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt --- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. +-- | Right biased +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x) + plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y) + -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of ===================================== compiler/GHC/Types/Var/Env.hs ===================================== @@ -12,7 +12,8 @@ module GHC.Types.Var.Env ( elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C, + plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, @@ -511,6 +512,7 @@ extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a varEnvDomain :: VarEnv elt -> UnVarSet @@ -522,6 +524,7 @@ delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b @@ -548,6 +551,7 @@ extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C +strictPlusVarEnv_C = strictPlusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM @@ -556,6 +560,7 @@ delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM +strictPlusVarEnv = strictPlusUFM plusVarEnvList = plusUFMList -- lookupVarEnv is very hot (in part due to being called by substTyVar), -- if it's not inlined than the mere allocation of the Just constructor causes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98918ebcf9a237d86d70cfe820eb794… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98918ebcf9a237d86d70cfe820eb794… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/imp-exp-whole-namespace] Update documentation
by Vladislav Zavialov (＠int-index) 29 Oct '25

29 Oct '25

Vladislav Zavialov pushed to branch wip/int-index/imp-exp-whole-namespace at Glasgow Haskell Compiler / GHC Commits: 6aabe758 by Vladislav Zavialov at 2025-10-29T14:34:28+03:00 Update documentation - - - - - 3 changed files: - compiler/GHC/Hs/Basic.hs - docs/users_guide/9.16.1-notes.rst - docs/users_guide/exts/explicit_namespaces.rst Changes: ===================================== compiler/GHC/Hs/Basic.hs ===================================== @@ -67,24 +67,26 @@ instance Binary FixityDirection where -- -- * import/export items -- * fixity signatures --- * WARNINIG and DEPRECATED pragmas +-- * @WARNINIG@ and @DEPRECATED@ pragmas -- -- Examples: -- --- module M (data ..) where --- -- ↑ DataNamespaceSpecifier +-- @ +-- module M (data ..) where +-- -- ↑ DataNamespaceSpecifier -- --- import Data.Proxy (type ..) as T --- -- ↑ TypeNamespaceSpecifier +-- import Data.Proxy as T (type ..) +-- -- ↑ TypeNamespaceSpecifier -- --- {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-} --- -- ↑ DataNamespaceSpecifier +-- {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-} +-- -- ↑ DataNamespaceSpecifier -- --- {-# DEPRECATED type D "This type was deprecated" #-} --- -- ↑ TypeNamespaceSpecifier +-- {-# DEPRECATED type D "This type was deprecated" #-} +-- -- ↑ TypeNamespaceSpecifier -- --- infixr 6 data $ --- -- ↑ DataNamespaceSpecifier +-- infixr 6 data $ +-- -- ↑ DataNamespaceSpecifier +-- @ data NamespaceSpecifier = NoNamespaceSpecifier | TypeNamespaceSpecifier (EpToken "type") @@ -112,4 +114,4 @@ coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace instance Outputable NamespaceSpecifier where ppr NoNamespaceSpecifier = empty ppr TypeNamespaceSpecifier{} = text "type" - ppr DataNamespaceSpecifier{} = text "data" \ No newline at end of file + ppr DataNamespaceSpecifier{} = text "data" ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -16,6 +16,9 @@ Language result, you may need to enable :extension:`DataKinds` in code that did not previously require it. +- The extension :extension:`ExplicitNamespaces` now allows namespace-specified + wildcards ``type ..`` and ``data ..`` in import and export lists. + Compiler ~~~~~~~~ ===================================== docs/users_guide/exts/explicit_namespaces.rst ===================================== @@ -118,6 +118,36 @@ The ``pattern`` keyword does the same, with only a few differences: The ``data`` keyword is preferred over ``pattern`` in import/export lists unless there is a need to support older GHC versions. +Wildcards in import/export lists +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +**Since:** GHC 9.16 + +Namespace-specified wildcards ``type ..`` and ``data ..`` may be used to import +all names in the corresponding namespace from a module: :: + + import M (type ..) -- imports all type and class constructors from M + import M (data ..) -- imports all data constructors and terms from M + +The primary intended use of this feature is in combination with module aliases, +allowing namespace disambiguation: :: + + import Data.Proxy as T (type ..) -- T.Proxy is unambiguously the type constructor + import Data.Proxy as D (data ..) -- D.Proxy is unambiguously the data constructor + +Using both wildcards ``import M (type .., data ..)`` is legal but redundant, as +it is equivalent to ``import M`` with no import list. + +Similarly, one may use wildcards in the export list of a module: :: + + module M (type .., f) where + -- exports all type and class constructors defined in M, + -- plus the function 'f' + +Using both wildcards ``module M (type .., data ..)`` is legal but redundant, as +it is equivalent to a whole module reexport ``module M (module M)``. + + Explicit namespaces in fixity declarations and warning/deprecation pragmas ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6aabe75818dbcd05758e01e7f80626d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6aabe75818dbcd05758e01e7f80626d… You're receiving this email because of your account on gitlab.haskell.org.

1 0