September 2026 - ghc-commits

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Add regression test for #7803
by Marge Bot (＠marge-bot) 29 Sep '26

29 Sep '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 234bab08 by Vladislav Zavialov at 2026-09-29T17:22:54-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - 11c7cec4 by Andreas Klebinger at 2026-09-29T17:31:32-04:00 Enable -fexpose-overloaded-unfoldings by default when optimizations are on. I also made the -fexpose-*-unfoldings flags optimization flags rather than codeGen flags. This was needed to fix a test and is the correct place for them. Performance numbers: In general this averages out to ~1% more file size across the GHC build. Compiler allocations grow by 0.14% on nofib as the compiler needs to deal with more available unfoldings. On the cabal test it's awash. With some configurations getting slightly faster, some slightly slower. It's all in the +/- 0.2% range. On nofib itself we produce exactly the same code. Which is expected, as it doesn't use -fspecialize-aggresively anywhere afaik which is needed to take advantage of cross module specialization. Fixes #13090 ------------------------- Metric Increase: LinkableUsage01 LinkableUsage02 hard_hole_fits ------------------------- - - - - - 9615bc9e by Andreas Klebinger at 2026-09-29T17:31:33-04:00 RTS: Update flag parsing/handling: Using 0 as argument to any of these flags now resets the flags setting to default: - ``-n0`` disables nursery chunking. - ``-K0`` (or a bare ``-K``) removes the stack size limit. - ``-M0`` removes the heap size limit. - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. - ``-AL0`` makes the large object allocation limit follow ``-A`` again. GC Generations are now limited to 64. -n larger than -A now emits a warning and disables chunking. Fixes #27830 #27829 - - - - - 265eb6d7 by Andreas Klebinger at 2026-09-29T17:31:34-04:00 Fix MultiLayerModules timeout multiplier. We accidentally used the compile multiplier for ghci commands which use the run timeout setting to set the timeout. Fixes #26263 and #27796. - - - - - 34dd943f by Andreas Klebinger at 2026-09-29T17:31:34-04:00 testsuite: Include runtime in JUnit report. - - - - - ae66d1d9 by Alan Zimmerman at 2026-09-29T17:31:35-04:00 EPA: Use EpaLocation in EpVirtualBraces Haddock processing uses EpLayout.EpVirtualBraces to record the current layout column, for allocating haddock comments correctly. For exact printing, we need the line as well as the col, so we know how many lines to skip when the indented code block starts. This commit updates EpLayout.EpVirtualBraces so that it carries an EpaLocation instead of just the Int column, to allow it to be used for both purposes. It is a simple mechanical change, with no other impact, but it allows us to use EpLayout instead of AnnListLayout in AnnList, in the next commit in this series. - - - - - 48 changed files: - + changelog.d/T13090-expose-overloaded-unfoldings - + changelog.d/T27830-rts-flag-bounds - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - docs/users_guide/runtime_control.rst - docs/users_guide/using-optimisation.rst - rts/RtsFlags.c - rts/include/rts/Flags.h - rts/include/rts/storage/GC.h - rts/sm/GC.c - rts/sm/Storage.c - testsuite/driver/junit.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/dmdanal/should_compile/T23398.stderr - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/perf/compiler/all.T - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/rts/all.T - testsuite/tests/rts/rtsflags001.stderr-ws-32 - testsuite/tests/rts/rtsflags001.stderr-ws-64 - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/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/5e12c24dfe0c337e4dc6619966336e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e12c24dfe0c337e4dc6619966336e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Add regression test for #7803
by Marge Bot (＠marge-bot) 29 Sep '26

29 Sep '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 234bab08 by Vladislav Zavialov at 2026-09-29T17:22:54-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - 4 changed files: - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== testsuite/tests/simplCore/should_compile/T7803.hs ===================================== @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -ddump-simpl #-} + +-- #7803: foo1 should be fully specialised at Double. In the bug report +-- it ended up calling the overloaded exp5Tail (with a dictionary argument), +-- because the specialiser ran before the overloaded call was floated to +-- the top level. So the dumped Core for this module must mention no +-- exp5Tail at all. +module T7803 (foo1) where + +import T7803a + +bar :: Floating a => a -> a -> a +bar z = subtract (evaluate integ z) . evaluate integ + where + integ = indefinite (Piecewise [Poly4 1]) +{-# SPECIALIZE bar :: Double -> Double -> Double #-} + +foo :: Floating a => a -> a -> a +foo x = bar x +{-# SPECIALIZE foo :: Double -> Double -> Double #-} + +foo1 :: Double -> Double -> Double +foo1 x = foo x ===================================== testsuite/tests/simplCore/should_compile/T7803.stderr ===================================== @@ -0,0 +1 @@ +foo1 ===================================== testsuite/tests/simplCore/should_compile/T7803a.hs ===================================== @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T7803a + ( Evaluate (..) + , HasIntegral (..) + , Poly4 (..) + , Domain + , IntOfLogPoly4 (..) + , Piecewise (..) + ) where + +import Data.Kind (Constraint, Type) + +class Evaluate poly where + evaluate :: (Domain' poly a) => poly a -> a -> a + +class Evaluate (IntegralOf poly) => HasIntegral poly where + type IntegralOf poly :: Type -> Type + indefinite :: (Domain' poly a, Domain' (IntegralOf poly) a) + => poly a -> IntegralOf poly a + +type family Domain (f :: Type -> Type) a :: Constraint + +class Domain f a => Domain' f a +instance Domain f a => Domain' f a + +newtype Poly4 a = Poly4 { poly4_a :: a } + +type instance Domain Poly4 a = Fractional a + +data IntOfLogPoly4 a = IntOfLogPoly4 { ilp4_k :: !a, ilp4_u :: !a } + +type instance Domain IntOfLogPoly4 a = Floating a + +instance Evaluate IntOfLogPoly4 where + evaluate (IntOfLogPoly4 k _) x = k + x * exp5Tail (- log x) + {-# INLINE evaluate #-} + +{-# RULES "exp5Tail/Double" exp5Tail = exp5TailDouble #-} +{-# NOINLINE exp5Tail #-} + +exp5Tail :: (Floating a) => a -> a +exp5Tail x = x / 120 + +exp5TailDouble :: Double -> Double +exp5TailDouble x = x / 120 + +instance HasIntegral Poly4 where + type IntegralOf Poly4 = IntOfLogPoly4 + indefinite = \ (Poly4 a) -> IntOfLogPoly4 0 a + {-# INLINE indefinite #-} + +newtype Piecewise poly a = Piecewise { unPiecewise :: [poly a] } + +type instance Domain (Piecewise poly) a = (Domain poly a, Num a) + +instance (Evaluate poly) => Evaluate (Piecewise poly) where + evaluate = \ (Piecewise pp) x -> + case pp of + p : _ -> evaluate p x + [] -> error "evaluate: empty Piecewise" + {-# INLINE evaluate #-} + +instance (HasIntegral poly) => HasIntegral (Piecewise poly) where + type IntegralOf (Piecewise poly) = Piecewise (IntegralOf poly) + indefinite (Piecewise m) = Piecewise $ map indefinite m + {-# INLINE indefinite #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -148,6 +148,13 @@ test('T7785', [ only_ways(['optasm']), grep_errmsg(r'SPEC') ], compile, ['-ddump-cse']) +# T7803: we expect NO calls to the overloaded 'exp5Tail' in T7803.hs +# In the bug report #7803, the unspecialised call was signalled by 'exp5Tail' +# in foo1's Core, so we grep for that; also for 'foo1', lest we dump nothing +# One module, T7803.hs, has OPTIONS_GHC -ddump-simpl +test('T7803', [ grep_errmsg(r'exp5Tail|foo1') ], + multimod_compile, ['T7803', '-O2 -v0 -dsuppress-all -dsuppress-uniques -dno-typeable-binds']) + test('T7702', [extra_files(['T7702plugin']), pre_cmd('$MAKE -s --no-print-directory -C T7702plugin package.T7702 TOP={top}'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/234bab081682018da7d04b22eee4b80… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/234bab081682018da7d04b22eee4b80… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/smaller-pit
by Wolfgang Jeltsch (＠jeltsch) 29 Sep '26

29 Sep '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/smaller-pit at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/smaller-pit You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/jeltsch/eps-without-mod-iface
by Wolfgang Jeltsch (＠jeltsch) 29 Sep '26

29 Sep '26

Wolfgang Jeltsch deleted branch wip/jeltsch/eps-without-mod-iface at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/eps-without-mod-iface] Reduce the amount of information stored in the PIT
by Wolfgang Jeltsch (＠jeltsch) 29 Sep '26

29 Sep '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/eps-without-mod-iface at Glasgow Haskell Compiler / GHC Commits: 187920b6 by Wolfgang Jeltsch at 2026-09-30T00:14:05+03:00 Reduce the amount of information stored in the PIT - - - - - 23 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Load.hs-boot - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModIface.hs - ghc/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -688,7 +688,8 @@ expandFixedModuleNode key loc = do -- part of the compiler. lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case Just iface -> return (M.Succeeded iface) - Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + Nothing -> fmap shrinkModIface <$> + readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) case read_result of M.Succeeded iface -> do -- Computer information about this node ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -372,10 +372,10 @@ lookupIfaceByModule :: HomeUnitGraph -> PackageIfaceTable -> Module - -> IO (Maybe ModIface) + -> IO (Maybe RetainedModIface) lookupIfaceByModule hug pit mod = HUG.lookupHugByModule mod hug >>= pure . \case - Just hm -> Just (hm_iface hm) + Just hm -> Just (shrinkModIface (hm_iface hm)) Nothing -> lookupModuleEnv pit mod -- If the module does come from the home package, why do we look in the PIT as well? -- (a) In OneShot mode, even home-package modules accumulate in the PIT @@ -384,7 +384,7 @@ lookupIfaceByModule hug pit mod -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. -lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface) +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe RetainedModIface) lookupIfaceByModuleHsc hsc_env mod = do eps <- hscEPS hsc_env lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod ===================================== compiler/GHC/Driver/Main/Interactive.hs ===================================== @@ -148,7 +148,7 @@ hscIsGHCiMonad :: HscEnv -> String -> IO Name hscIsGHCiMonad hsc_env name = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name -hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface :: HscEnv -> Module -> IO RetainedModIface hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod @@ -270,7 +270,7 @@ hscCheckSafe' m l = do _ | isHomeModule home_unit mod -> True _ -> isUnitTrusted unit_state (moduleUnit m) - lookup' :: Module -> Hsc (Maybe ModIface) + lookup' :: Module -> Hsc (Maybe RetainedModIface) lookup' m = do hsc_env <- getHscEnv iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m ===================================== compiler/GHC/Driver/Main/Passes.hs ===================================== @@ -1335,7 +1335,7 @@ hscCheckSafe' m l = do _ | isHomeModule home_unit mod -> True _ -> isUnitTrusted unit_state (moduleUnit m) - lookup' :: Module -> Hsc (Maybe ModIface) + lookup' :: Module -> Hsc (Maybe RetainedModIface) lookup' m = do hsc_env <- getHscEnv iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -224,7 +224,7 @@ data PluginWithArgs = PluginWithArgs data LoadedPlugin = LoadedPlugin { lpPlugin :: PluginWithArgs -- ^ the actual plugin together with its commandline arguments - , lpModule :: ModIface + , lpModule :: RetainedModIface -- ^ the module containing the plugin } ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -87,7 +87,7 @@ data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: [AvailInfo], minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, + minf_iface :: Maybe RetainedModIface, minf_safe :: SafeHaskellMode, minf_modBreaks :: Maybe InternalModBreaks } @@ -140,7 +140,7 @@ getHomeModuleInfo hsc_env mdl = Nothing -> return Nothing Just hmi -> do let details = hm_details hmi - iface = hm_iface hmi + iface = shrinkModIface (hm_iface hmi) return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, @@ -187,7 +187,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do Just tyThing -> return (Just tyThing) Nothing -> liftIO (lookupType hsc_env name) -modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface :: ModuleInfo -> Maybe RetainedModIface modInfoIface = minf_iface -- | Retrieve module safe haskell mode ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -276,7 +276,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u -- a) we used something from it; has something in used_names -- b) we imported it, even if we used nothing from it -- (need to recompile if its export list changes: export_fprint) - mkUsage :: Module -> ModIface -> Maybe Usage + mkUsage :: Module -> RetainedModIface -> Maybe Usage mkUsage mod iface | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, @@ -302,9 +302,9 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u usg_entities = Map.toList ent_hashs, usg_safe = imp_safe } where - finsts_mod = mi_finsts iface + finsts_mod = mi_abi_finsts (mi_abi_hashes iface) hash_env = mi_hash_fn iface - mod_hash = mi_mod_hash iface + mod_hash = mi_abi_mod_hash (mi_abi_hashes iface) imported_exports = if not depend_on_exports then Nothing @@ -312,9 +312,9 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u Just $ HomeModImport { hmiu_orphanLikeHash - = mi_orphan_like_hash iface + = mi_abi_orphan_like_hash (mi_abi_hashes iface) , hmiu_importedAvails - = moduleImportedAvails mod (mi_export_avails_hash iface) imp_decls + = moduleImportedAvails mod (mi_abi_export_avails_hash (mi_abi_hashes iface)) imp_decls } by_is_safe (ImportedByUser imv) = imv_is_safe imv ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -308,7 +308,7 @@ loadKnownKeyOccMaps known_key_maps :: Module -> IfM lcl KnownKeyNameMaps known_key_maps mod = do { iface <- loadInterfaceWithException doc mod ImportBySystem - ; let !abi_hash = mi_mod_hash iface + ; let !abi_hash = mi_abi_mod_hash (mi_abi_hashes iface) ; eps <- getEps ; case lookupModuleEnv (eps_known_keys eps) mod of Just (cached_hash, kk_maps) @@ -321,7 +321,7 @@ loadKnownKeyOccMaps (abi_hash, kk_maps) } ; return kk_maps } } - build_maps :: ModIface -> KnownKeyNameMaps + build_maps :: RetainedModIface -> KnownKeyNameMaps build_maps iface = (kk_map, occ_map) where kk_map :: UniqFM KnownKey Name @@ -628,7 +628,7 @@ loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM ModIface + -> RnM RetainedModIface loadSrcInterface doc scope mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc scope mod want_boot maybe_pkg @@ -648,7 +648,7 @@ loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM (MaybeErr MissingInterfaceError ModIface) + -> RnM (MaybeErr MissingInterfaceError RetainedModIface) loadSrcInterface_maybe doc scope mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -667,7 +667,7 @@ loadSrcInterface_maybe doc scope mod want_boot maybe_pkg -- rare operation, but in particular it is used to load orphan modules -- in order to pull their instances into the global package table and to -- handle some operations in GHCi). -loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface :: SDoc -> Module -> TcM RetainedModIface loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) -- | Load interfaces for a collection of modules. @@ -681,7 +681,7 @@ loadModuleInterfaces doc mods -- | Loads the interface for a given Name. -- Should only be called for an imported name; -- otherwise loadSysInterface may not find the interface -loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName :: SDoc -> Name -> TcRn RetainedModIface loadInterfaceForName doc name = do { when debugIsOn $ -- Check pre-condition do { this_mod <- getModule @@ -690,7 +690,7 @@ loadInterfaceForName doc name initIfaceTcRn $ loadSysInterface doc (nameModule name) } -- | Loads the interface for a given Module. -loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface +loadInterfaceForModule :: SDoc -> Module -> TcRn RetainedModIface loadInterfaceForModule doc m = do -- Should not be called with this module @@ -724,23 +724,23 @@ loadWiredInHomeIface name ------------------ -- | Loads a system interface and throws an exception if it fails -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface :: SDoc -> Module -> IfM lcl RetainedModIface loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem ------------------ -- | Loads a user interface and throws an exception if it fails. The first parameter indicates -- whether we should import the boot variant of the module -loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl RetainedModIface loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot) -loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface +loadPluginInterface :: SDoc -> Module -> IfM lcl RetainedModIface loadPluginInterface doc mod_name = loadInterfaceWithException doc mod_name ImportByPlugin ------------------ -- | A wrapper for 'loadInterface' that throws an exception if it fails -loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl RetainedModIface loadInterfaceWithException doc mod_name where_from = do dflags <- getDynFlags @@ -749,7 +749,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr MissingInterfaceError ModIface) + -> IfM lcl (MaybeErr MissingInterfaceError RetainedModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -796,7 +796,7 @@ loadInterface doc_str mod from liftIO $ computeInterface hsc_env doc_str hi_boot_file mod ; case read_result of { Failed err -> do - { let fake_iface = emptyFullModIface mod + { let fake_iface = shrinkModIface (emptyFullModIface mod) ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -856,16 +856,7 @@ loadInterface doc_str mod from ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) ; purged_hsc_env <- getTopEnv - ; let final_iface = iface - & set_mi_decls (panic "No mi_decls in PIT") - & set_mi_insts (panic "No mi_insts in PIT") - & set_mi_defaults (panic "No mi_defaults in PIT") - & set_mi_fam_insts (panic "No mi_fam_insts in PIT") - & set_mi_rules (panic "No mi_rules in PIT") - & set_mi_anns (panic "No mi_anns in PIT") - & set_mi_simplified_core (panic "No mi_simplified_core in PIT") - - bad_boot = mi_boot iface == IsBoot + ; let bad_boot = mi_boot iface == IsBoot && isJust (lookupKnotVars (if_rec_types gbl_env) mod) -- Warn against an EPS-updating import -- of one's own boot file! (one-shot only) @@ -892,7 +883,7 @@ loadInterface doc_str mod from then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls } else eps { - eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PIT = extendModuleEnv (eps_PIT eps) mod (shrinkModIface iface), eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps), eps_rule_base = extendRuleBaseList (eps_rule_base eps) @@ -921,10 +912,8 @@ loadInterface doc_str mod from eps_defaults = extendModuleEnv (eps_defaults eps) mod new_eps_defaults } - ; -- invoke plugins with *full* interface, not final_iface, to ensure - -- that plugins have access to declarations, etc. - res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface - ; return (Succeeded res) + ; res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface + ; return (Succeeded (shrinkModIface res)) }}}} {- Note [Loading your own hi-boot file] ===================================== compiler/GHC/Iface/Load.hs-boot ===================================== @@ -2,7 +2,7 @@ module GHC.Iface.Load where import GHC.Unit.Module (Module) import GHC.Tc.Utils.Monad (IfM) -import GHC.Unit.Module.ModIface (ModIface) +import GHC.Unit.Module.ModIface (RetainedModIface) import GHC.Utils.Outputable (SDoc) -loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface :: SDoc -> Module -> IfM lcl RetainedModIface ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -707,7 +707,7 @@ checkDependencies hsc_env summary iface return $ needsRecompileBecause $ ModulePackageChanged new_name -needInterface :: Module -> (ModIface -> IO RecompileRequired) +needInterface :: Module -> (RetainedModIface -> IO RecompileRequired) -> IfG RecompileRequired needInterface mod continue = do @@ -727,7 +727,7 @@ needBytecode mod continue Nothing -> return $ NeedsRecompile MustCompile Just mbc -> liftIO $ continue mbc -tryGetModIface :: String -> Module -> IfG (Maybe ModIface) +tryGetModIface :: String -> Module -> IfG (Maybe RetainedModIface) tryGetModIface doc_msg mod = do -- Load the imported interface if possible logger <- getLogger @@ -779,7 +779,7 @@ checkModUsage _ UsagePackageModule{ logger <- getLogger needInterface mod $ \iface -> do let reason = ModuleChanged (moduleName mod) - checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) + checkModuleFingerprint logger reason old_mod_hash (mi_abi_mod_hash (mi_abi_hashes iface)) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when @@ -789,7 +789,7 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha logger <- getLogger needInterface mod $ \iface -> do let reason = ModuleChangedRaw (moduleName mod) - checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) + checkModuleFingerprint logger reason old_mod_hash (mi_abi_mod_hash (mi_abi_hashes iface)) checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name , usg_unit_id = uid , usg_bytecode_hash = old_bytecode_hash } = do @@ -810,7 +810,7 @@ checkModUsage _ UsageHomeModule{ logger <- getLogger needInterface mod $ \iface -> do let - new_mod_hash = mi_mod_hash iface + new_mod_hash = mi_abi_mod_hash (mi_abi_hashes iface) new_decl_hash = mi_hash_fn iface reason = ModuleChanged (moduleName mod) @@ -864,7 +864,7 @@ checkModUsage fc UsageDirectory{ usg_dir_path = dir, -- Does this require recompilation? -- -- See Note [When to recompile when export lists change?] -checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired +checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> RetainedModIface -> IO RecompileRequired checkHomeModImport _ _ Nothing _ = return UpToDate checkHomeModImport logger reason (Just (HomeModImport old_orphan_like_hash old_avails)) @@ -901,8 +901,8 @@ checkHomeModImport logger reason 2 (ppr changes) return $ needsRecompileBecause reason where - new_orphan_like_hash = mi_orphan_like_hash iface - new_avails_hash = mi_export_avails_hash iface + new_orphan_like_hash = mi_abi_orphan_like_hash (mi_abi_hashes iface) + new_avails_hash = mi_abi_export_avails_hash (mi_abi_hashes iface) new_exports = mi_exports iface -- | The exported avails of a module have changed. Should this cause recompilation @@ -1617,7 +1617,7 @@ getOrphanHashes hsc_env mods = do get_orph_hash mod = do iface <- initIfaceLoad hsc_env . withIfaceErr ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash iface) + return (mi_abi_orphan_hash (mi_abi_hashes iface)) mapM get_orph_hash mods ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -517,7 +517,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit -> S.Set UnitId - -> ModIface + -> RetainedModIface -> IsSafeImport -> IsBootInterface -> ImportedBy @@ -525,8 +525,8 @@ calculateAvails :: HomeUnit calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan iface - has_finsts = mi_finsts iface + orph_iface = mi_abi_orphan (mi_abi_hashes iface) + has_finsts = mi_abi_finsts (mi_abi_hashes iface) deps = mi_deps iface trust = getSafeMode $ mi_trust iface trust_pkg = mi_trust_pkg iface @@ -1209,7 +1209,7 @@ gresFromAvail hsc_env prov avail = gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov) -importsFromIface :: HscEnv -> ModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv +importsFromIface :: HscEnv -> RetainedModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv importsFromIface hsc_env iface decl_spec hidden = mkGlobalRdrEnv $ case hidden of Nothing -> all_gres Just hidden_names -> filter (not . (`elemNameSet` hidden_names) . greName) all_gres @@ -1225,7 +1225,7 @@ rnNamespaceSpecifier (DataNamespaceSpecifier x) = DataNamespaceSpecifier x filterImports :: HasDebugCallStack => HscEnv - -> ModIface + -> RetainedModIface -> ImpDeclSpec -- ^ Import spec -> Maybe (ImportListInterpretation, [LIE GhcPs]) @@ -2327,7 +2327,7 @@ getMinimalImports ie_decls where doc = text "Compute minimal imports for" <+> ppr decl - to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn] + to_ie :: GlobalRdrEnv -> RetainedModIface -> AvailInfo -> RnM [IE GhcRn] -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -2529,7 +2529,7 @@ DRFPatSynExport for a test of this. -} badImportItemErr - :: ModIface -> ImpDeclSpec -> IE GhcPs + :: RetainedModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinateError -> [AvailInfo] -> TcRn (NonEmpty ImportLookupReason) ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -534,7 +534,7 @@ warnIfDeclDeprecated gre@(GRE { gre_imp = iss }) definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" -lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) +lookupImpDeclDeprec :: RetainedModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeclDeprec iface gre -- Bleat if the thing, or its parent, is warn'd = mi_decl_warn_fn iface (greOccName gre) `mplus` ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -190,7 +190,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of -> throwIO (InstallationError "Plugins require -fno-external-interpreter") _ -> pure () -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableUsage], PkgsLoaded) +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, RetainedModIface, [LinkableUsage], PkgsLoaded) loadPlugin' occ_name plugin_name hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env @@ -341,7 +341,7 @@ lessUnsafeCoerce logger context what = do -- Need the module as well to record information in the interface file lookupRdrNameInModuleForPlugins :: HasDebugCallStack => HscEnv -> ModuleName -> RdrName - -> IO (Maybe (Name, ModIface)) + -> IO (Maybe (Name, RetainedModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env -- First find the unit the module resides in by searching exposed units and home modules ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -6386,7 +6386,7 @@ pprImportLookup :: ImportLookupReason -> SDoc pprImportLookup = \case ImportLookupBad k iface decl_spec ie _exts -> let - pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc + pprImpDeclSpec :: RetainedModIface -> ImpDeclSpec -> SDoc pprImpDeclSpec iface decl_spec = quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of IsBoot -> text "(hi-boot interface)" ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -215,7 +215,7 @@ import GHC.Types.DefaultEnv (ClassDefaults) import GHC.Unit.Types (Module) import GHC.Unit.State (UnitState) -import GHC.Unit.Module.ModIface (ModIface) +import GHC.Unit.Module.ModIface (RetainedModIface) import GHC.Utils.Outputable @@ -6635,7 +6635,7 @@ data ImportLookupReason where T9006, T11071, T9905fail2, T5385, T10668 -} ImportLookupBad :: BadImportKind - -> ModIface + -> RetainedModIface -> ImpDeclSpec -> IE GhcPs -> ImportLookupExtensions ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1693,7 +1693,7 @@ lookupArgDoc i nm = do _ -> pure Nothing -- | Returns the module a Name belongs to, if it is isn't local. -getExternalModIface :: Name -> TcM (Maybe ModIface) +getExternalModIface :: Name -> TcM (Maybe RetainedModIface) getExternalModIface nm = do isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm if isLocal ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -308,7 +308,7 @@ checkFamInstConsistency directlyImpMods ifc <- modIface mod deps <- dep_finsts . mi_deps <$> modIface mod pure $ - if mi_finsts ifc + if mi_abi_finsts (mi_abi_hashes ifc) then mod:deps else deps ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2964,7 +2964,7 @@ externaliseAndTidyId this_mod id -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe RetainedModIface) getModuleInterface hsc_env mod = runTcInteractive NoTcMPlugins hsc_env $ loadModuleInterface (text "getModuleInterface") mod ===================================== compiler/GHC/Unit/External.hs ===================================== @@ -49,7 +49,7 @@ type PackageAnnEnv = AnnEnv type PackageCompleteMatches = CompleteMatches -- | Helps us find information about modules in the imported packages -type PackageIfaceTable = ModuleEnv ModIface +type PackageIfaceTable = ModuleEnv RetainedModIface -- Domain = modules in the imported packages -- | Constructs an empty PackageIfaceTable ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Unit.Module.ModIface ( ModIface @@ -68,6 +69,7 @@ module GHC.Unit.Module.ModIface , set_mi_fix_fn , set_mi_hash_fn , completePartialModIface + , shrinkModIface , IfaceBinHandle(..) , PartialModIface , RetainedModIface @@ -82,8 +84,6 @@ module GHC.Unit.Module.ModIface , IfaceAnnotationsData , IfaceDeclsData , IfaceDefaultsData - , IfaceClsInstsData - , IfaceFamInstsData , IfaceRulesData , IfaceCompleteMatchesData , IfaceAbiHashesData @@ -268,23 +268,13 @@ type family IfaceAnnotationsData (phase :: ModIfacePhase) where type family IfaceDeclsData (phase :: ModIfacePhase) where IfaceDeclsData 'ModIfaceCore = [IfaceDecl] IfaceDeclsData 'ModIfaceFinal = [(Fingerprint, IfaceDecl)] - IfaceDeclsData 'ModIfaceRetained = () + IfaceDeclsData 'ModIfaceRetained = [IfaceDecl] type family IfaceDefaultsData (phase :: ModIfacePhase) where IfaceDefaultsData 'ModIfaceCore = [IfaceDefault] IfaceDefaultsData 'ModIfaceFinal = [IfaceDefault] IfaceDefaultsData 'ModIfaceRetained = () -type family IfaceClsInstsData (phase :: ModIfacePhase) where - IfaceClsInstsData 'ModIfaceCore = [IfaceClsInst] - IfaceClsInstsData 'ModIfaceFinal = [IfaceClsInst] - IfaceClsInstsData 'ModIfaceRetained = () - -type family IfaceFamInstsData (phase :: ModIfacePhase) where - IfaceFamInstsData 'ModIfaceCore = [IfaceFamInst] - IfaceFamInstsData 'ModIfaceFinal = [IfaceFamInst] - IfaceFamInstsData 'ModIfaceRetained = () - type family IfaceRulesData (phase :: ModIfacePhase) where IfaceRulesData 'ModIfaceCore = [IfaceRule] IfaceRulesData 'ModIfaceFinal = [IfaceRule] @@ -413,9 +403,9 @@ data IfacePublic_ phase = IfacePublic { -- Instance declarations and rules - mi_insts_ :: IfaceClsInstsData phase, -- ^ Sorted class instance - mi_fam_insts_ :: IfaceFamInstsData phase, -- ^ Sorted family instances - mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules + mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules mi_trust_ :: IfaceTrustInfo, @@ -608,7 +598,7 @@ mi_orphan_hash iface = mi_abi_orphan_hash (mi_abi_hashes iface) -- | Old-style accessor for whether or not the ModIface came from an hs-boot -- file. -mi_boot :: ModIface -> IsBootInterface +mi_boot :: ModIface_ phase -> IsBootInterface mi_boot iface = if mi_hsc_src iface == HsBootFile then IsBoot else NotBoot @@ -618,7 +608,7 @@ mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface) -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be -- found, 'defaultFixity' is returned instead. -mi_fix :: ModIface -> OccName -> Fixity +mi_fix :: ModIface_ phase -> OccName -> Fixity mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity -- | The semantic module for this interface; e.g., if it's a interface @@ -634,7 +624,7 @@ mi_semantic_module iface = mi_mod_info_semantic_module (mi_mod_info iface) -- | The "precise" free holes, e.g., the signatures that this -- 'ModIface' depends on. -mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes :: ModIface_ phase -> UniqDSet ModuleName mi_free_holes iface = case getModuleInstantiation (mi_module iface) of (_, Just indef) @@ -851,8 +841,8 @@ emptyIfaceModInfo mod = IfaceModInfo emptyPublicModIface :: IfaceAnnotationsData phase -> IfaceDeclsData phase -> IfaceDefaultsData phase - -> IfaceClsInstsData phase - -> IfaceFamInstsData phase + -> [IfaceClsInst] + -> [IfaceFamInst] -> IfaceRulesData phase -> IfaceCompleteMatchesData phase -> IfaceAbiHashesData phase @@ -930,8 +920,6 @@ instance ( NFData (IfaceSelfRecompData phase) , NFData (IfaceAnnotationsData phase) , NFData (IfaceDeclsData phase) , NFData (IfaceDefaultsData phase) - , NFData (IfaceClsInstsData phase) - , NFData (IfaceFamInstsData phase) , NFData (IfaceRulesData phase) , NFData (IfaceCompleteMatchesData phase) , NFData (IfaceAbiHashesData phase) @@ -970,8 +958,6 @@ instance NFData IfaceAbiHashes where instance ( NFData (IfaceAnnotationsData phase) , NFData (IfaceDeclsData phase) , NFData (IfaceDefaultsData phase) - , NFData (IfaceClsInstsData phase) - , NFData (IfaceFamInstsData phase) , NFData (IfaceRulesData phase) , NFData (IfaceCompleteMatchesData phase) , NFData (IfaceAbiHashesData phase) @@ -1051,7 +1037,6 @@ completePartialModIface partial iface_hash decls extra_decls final_exts cache = , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing , mi_iface_hash_ = iface_hash } - where -- | Given a 'PartialIfacePublic', turn it into an 'IfacePublic' by completing -- missing fields. @@ -1066,6 +1051,30 @@ completePublicModIface decls abi_hashes cache partial = partial , mi_caches_ = cache } +shrinkModIface :: ModIface -> RetainedModIface +shrinkModIface PrivateModIface {..} + = PrivateModIface + { + mi_hi_bytes_ = RetainedIfaceBinHandle, + mi_public_ = shrinkIfacePublic mi_public_, + mi_self_recomp_ = (), + mi_simplified_core_ = (), + mi_ext_fields_ = (), + .. + } + +shrinkIfacePublic :: IfacePublic -> RetainedIfacePublic +shrinkIfacePublic IfacePublic {..} + = IfacePublic + { + mi_anns_ = (), + mi_decls_ = map snd mi_decls_, + mi_defaults_ = (), + mi_rules_ = (), + mi_complete_matches_ = (), + .. + } + set_mi_mod_info :: IfaceModInfo -> ModIface_ phase -> ModIface_ phase set_mi_mod_info val iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = val } @@ -1107,10 +1116,10 @@ set_mi_warns val = set_mi_public (\iface -> iface { mi_warns_ = val }) set_mi_anns :: IfaceAnnotationsData phase -> ModIface_ phase -> ModIface_ phase set_mi_anns val = set_mi_public (\iface -> iface { mi_anns_ = val }) -set_mi_insts :: IfaceClsInstsData phase -> ModIface_ phase -> ModIface_ phase +set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val }) -set_mi_fam_insts :: IfaceFamInstsData phase -> ModIface_ phase -> ModIface_ phase +set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase set_mi_fam_insts val = set_mi_public (\iface -> iface { mi_fam_insts_ = val }) set_mi_rules :: IfaceRulesData phase -> ModIface_ phase -> ModIface_ phase @@ -1282,8 +1291,8 @@ pattern ModIface :: -> IfaceSimplifiedCoreData phase -> IfaceDefaultsData phase -> IfaceTopEnv - -> IfaceClsInstsData phase - -> IfaceFamInstsData phase + -> [IfaceClsInst] + -> [IfaceFamInst] -> IfaceRulesData phase -> IfaceTrustInfo -> Bool ===================================== ghc/Main.hs ===================================== @@ -515,7 +515,7 @@ abiHash strs = do put_ bh hiVersion -- package hashes change when the compiler version changes (for now) -- see #5328 - mapM_ (put_ bh . mi_mod_hash) ifaces + mapM_ (put_ bh . mi_abi_mod_hash . mi_abi_hashes) ifaces f <- fingerprintBinMem bh putStrLn (showPpr dflags f) ===================================== utils/haddock/haddock-api/src/Haddock/Interface.hs ===================================== @@ -74,7 +74,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..)) import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.ModIface (mi_semantic_module, mi_boot) +import GHC.Unit.Module.ModIface (RetainedModIface, shrinkModIface, mi_semantic_module, mi_boot) import GHC.Unit.Module.ModSummary (isBootSummary) import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text) import GHC.Utils.Error (withTiming) @@ -254,7 +254,7 @@ dropErr :: MaybeErr e a -> Maybe a dropErr (Succeeded a) = Just a dropErr (Failed _) = Nothing -loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (ModIface, ([ClsInst], [FamInst])) +loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (RetainedModIface, ([ClsInst], [FamInst])) loadHiFile hsc_env doc theModule = initIfaceLoad hsc_env $ do mod_iface <- loadSysInterface doc theModule @@ -288,7 +288,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do let cls_insts = instEnvElts . md_insts $ hm_details hmi fam_insts = md_fam_insts $ hm_details hmi - pure (hm_iface hmi, (cls_insts, fam_insts)) + pure (shrinkModIface (hm_iface hmi), (cls_insts, fam_insts)) !interface <- do logger <- getLogger ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Create.hs ===================================== @@ -81,7 +81,7 @@ createInterface1 => [Flag] -> UnitState -> ModSummary - -> ModIface + -> RetainedModIface -> IfaceMap -> InstIfaceMap -> ([ClsInst], [FamInst]) @@ -105,7 +105,7 @@ createInterface1' -> UnitState -> DynFlags -> FilePath - -> ModIface + -> RetainedModIface -> IfaceMap -> InstIfaceMap -> ([ClsInst], [FamInst]) @@ -150,7 +150,7 @@ createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces def_meths_env = mkOccEnv def_meths def_meths = [ (nameOccName nm, nm) - | (_, IfaceId{ifName = nm}) <- mi_decls mod_iface + | IfaceId{ifName = nm} <- mi_decls mod_iface , let occ = nameOccName nm , isDefaultMethodOcc occ ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/187920b687e2e35c8b8d0ae0f681dbd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/187920b687e2e35c8b8d0ae0f681dbd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/apk/unfold-dicts] 2 commits: Make T27225 test more stable.
by Andreas Klebinger (＠AndreasK) 29 Sep '26

29 Sep '26

Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC Commits: 38b4fe14 by Andreas Klebinger at 2026-09-29T19:46:59+00:00 Make T27225 test more stable. Rather than checking for all cost centres, only check for the hand inserted ones from Main. This means the test no longer depends on what sccs are in the boot libs. - - - - - df0eb780 by Andreas Klebinger at 2026-09-29T19:56:00+00:00 Tweak inlining discout for unary class ops. Correctly account for arguments applied to the result of the class op application when computing rhs size for unary classes. I also fixed handling of casts/ticks while in the area. Fixes #27802 Fixes #27818 ------------------------- Metric Decrease: CoOpt_Singletons Metric Increase: T12234 T21839c T21839r T5321FD T5321Fun hard_hole_fits T18223 ------------------------- - - - - - 16 changed files: - + changelog.d/T27802-classop-arg-size - + changelog.d/T27818-unfolding-size-casts-ticks - compiler/GHC/Core/Unfold.hs - testsuite/tests/arityanal/should_compile/Arity01.stderr - testsuite/tests/arityanal/should_compile/Arity05.stderr - testsuite/tests/arityanal/should_compile/Arity08.stderr - testsuite/tests/arityanal/should_compile/Arity11.stderr - testsuite/tests/arityanal/should_compile/Arity14.stderr - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/dmdanal/should_compile/T23398.stderr - testsuite/tests/ghci.debugger/scripts/break021.stdout - testsuite/tests/profiling/should_run/T27225.stdout - testsuite/tests/profiling/should_run/T27225b.stdout - testsuite/tests/profiling/should_run/all.T - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T26117.stderr Changes: ===================================== changelog.d/T27802-classop-arg-size ===================================== @@ -0,0 +1,11 @@ +section: compiler +issues: #27802 +mrs: !16675 +synopsis: + Account for arguments applied to unary class methods when computing unfolding size. +description: { + Due to a bug we considered the application of arguments to a unary class method free + during expression size calculation. We now accurately calculate the discount again. + + This might make some functions heavy on single-class method use no longer inline. +} ===================================== changelog.d/T27818-unfolding-size-casts-ticks ===================================== @@ -0,0 +1,5 @@ +section: compiler +issues: #27818 +mrs: !16675 +synopsis: + Fixed a bug that caused newtypes and cost centres to affect inlining decisions. ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -335,6 +335,10 @@ isValFun :: CoreExpr -> Bool -- one top-level value lambda isValFun (Lam b e) | isRuntimeVar b = True | otherwise = isValFun e +-- A tick can be code which *can* change the runtime semantics here. +-- But we want to ignore it anyway. See Note [Ticks and Cast should not impact unfolding guidance] +isValFun (Tick _t e) = isValFun e +isValFun (Cast e _co) = isValFun e isValFun _ = False calcUnfoldingGuidance @@ -669,6 +673,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr is_inline_scrut (Var v) = isUnliftedType (idType v) -- isUnliftedType is OK here: scrutinees have a fixed RuntimeRep (search for FRRCase) + -- Even if this makes the check technically wrong we want to + -- look through ticks here. + -- See Note [Ticks and Cast should not impact unfolding guidance] + is_inline_scrut (Tick _t e) = is_inline_scrut e + is_inline_scrut (Cast e _co) = is_inline_scrut e is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of @@ -709,7 +718,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr FCallId _ -> sizeN (callSize (length val_args) voids) DataConWorkId dc -> conSize dc (length val_args) PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId cls _ -> classOpSize opts cls top_args val_args + ClassOpId cls _ -> classOpSize opts cls top_args val_args voids _ | fun `hasKey` buildIdKey -> buildSize | fun `hasKey` augmentIdKey -> augmentSize | otherwise -> funSize opts top_args fun (length val_args) voids @@ -761,9 +770,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr -- and typePrimRep will crash isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id) - isZeroBitExpr (Var id) = isZeroBitId id - isZeroBitExpr (Tick _ e) = isZeroBitExpr e - isZeroBitExpr _ = False + -- [Ticks and Cast should not impact unfolding guidance] + isZeroBitExpr (Var id) = isZeroBitId id + isZeroBitExpr (Tick _t e) = isZeroBitExpr e + isZeroBitExpr (Cast e _co) = isZeroBitExpr e + isZeroBitExpr _ = False -- | Finds a nominal size of a string literal. litSize :: Literal -> Int @@ -777,21 +788,31 @@ litSize _other = 0 -- Must match size of nullary constructors -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) -classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize +classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> Int -> ExprSize -- See (IA1) in Note [Interesting arguments] in GHC.Core.Opt.Simplify.Utils -classOpSize _opts _cls _top_args [] +classOpSize _opts _cls _top_args [] _voids = sizeZero -- A non-applied classop -classOpSize opts cls top_args (dict_arg:other_val_args) - = SizeIs size (arg_discount dict_arg) 0 +classOpSize opts cls top_args (dict_arg:other_val_args) voids + = SizeIs size dict_arg_discount 0 where - size | isUnaryClass cls = 0 -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon - | otherwise = 20 + (10 * length other_val_args) + -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon + op_app_size = if isUnaryClass cls then 0 else 20 + + -- Size penalty for applying the extracted class method to it's + -- arguments. + method_app_size + | null other_val_args = 0 -- we don't actually apply the result + | otherwise = callSize (length other_val_args) voids + + size = op_app_size + method_app_size -- If the class op is scrutinising a lambda bound dictionary then -- give it a discount, to encourage the inlining of this function - arg_discount (Cast arg _co) = arg_discount arg - arg_discount (Var dict) | dict `elem` top_args = unitBag (dict, dict_discount) - arg_discount _ = emptyBag + dict_arg_discount = case getIdFromTrivialExpr_maybe dict_arg of + Nothing -> emptyBag + Just var + | var `elem` top_args -> unitBag (var, dict_discount) + | otherwise -> emptyBag -- If we have (class-op d arg1 .. argn) then it's super-good to inline -- to expose `d`; not only can we do the dictionary selection @@ -1051,6 +1072,23 @@ In a function application (f a b) get a saturated application) Code for manipulating sizes + +Note [Ticks and Cast should not impact unfolding guidance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to ignore ticks and casts when +computing unfolding guidance. The reason is simple: + +We want inlining to be robust if a user changes a type alias +to a newtype, if the code is otherwise the same. + +Similarly we want inlining to behave the same for a core expression +(<tick> e) as it does for `e`. +This is **independent** of the kind of tick we are dealing with. +Even for ticks that represent code at runtime we generally want +to inline as-if no tick is present. This way profiled code will +be closer to non-profiled code, which leads to more accurate profiles. + +So we take care to look through Cast/Ticks wherever possible. -} -- | The size of a candidate expression for unfolding ===================================== testsuite/tests/arityanal/should_compile/Arity01.stderr ===================================== @@ -45,7 +45,7 @@ F1.s1 = GHC.Internal.Bignum.Integer.IS 3# -- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0} s :: forall {t1} {t2}. Num t1 => (t1 -> t2) -> t2 -[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60] 50 0}] +[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60] 60 0}] s = \ (@t) (@t1) ($dNum :: Num t) (f :: t -> t1) -> f (fromInteger @t $dNum F1.s1) -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} ===================================== testsuite/tests/arityanal/should_compile/Arity05.stderr ===================================== @@ -9,12 +9,12 @@ F5.f5g1 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 12, types: 9, coercions: 0, joins: 0/0} f5g :: forall {a} {t}. Num a => (t -> a) -> t -> a -[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 60 0] 90 0}] +[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 60 0] 110 0}] f5g = \ (@a) (@t) ($dNum :: Num a) (h :: t -> a) (z :: t) -> + @a $dNum (h z) (fromInteger @a $dNum F5.f5g1) -- RHS size: {terms: 17, types: 12, coercions: 0, joins: 0/0} f5h :: forall {a} {t}. Num a => (t -> a) -> t -> (t -> a) -> a -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 60 0 60] 150 0}] +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 60 0 60] 180 0}] f5h = \ (@a) (@t) ($dNum :: Num a) (f :: t -> a) (x :: t) (g :: t -> a) -> + @a $dNum (f x) (+ @a $dNum (g x) (fromInteger @a $dNum F5.f5g1)) -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} ===================================== testsuite/tests/arityanal/should_compile/Arity08.stderr ===================================== @@ -3,12 +3,12 @@ Result size of Tidy Core = {terms: 24, types: 18, coercions: 0, joins: 0/0} -- RHS size: {terms: 20, types: 10, coercions: 0, joins: 0/0} -f8f :: forall {p}. Num p => Bool -> p -> p -> p -[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 30 0 0] 140 0}] +f8f :: forall {a}. Num a => Bool -> a -> a -> a +[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 30 0 0] 170 0}] f8f - = \ (@p) ($dNum :: Num p) (b :: Bool) (x :: p) (y :: p) -> + = \ (@a) ($dNum :: Num a) (b :: Bool) (x :: a) (y :: a) -> case b of { - False -> + @p $dNum (+ @p $dNum x y) (* @p $dNum x x); + False -> + @a $dNum (+ @a $dNum x y) (* @a $dNum x x); True -> y } ===================================== testsuite/tests/arityanal/should_compile/Arity11.stderr ===================================== @@ -19,7 +19,7 @@ F11.fib1 = GHC.Internal.Bignum.Integer.IS 0# -- RHS size: {terms: 54, types: 27, coercions: 0, joins: 0/5} fib :: forall {t1} {t2}. (Eq t1, Num t1, Num t2) => t1 -> t2 -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 450 180 0] 480 0}] +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 450 180 0] 570 0}] fib = \ (@t) (@t1) ($dEq :: Eq t) ($dNum :: Num t) ($dNum1 :: Num t1) (eta :: t) -> let { @@ -105,7 +105,7 @@ F11.f11f1 = \ (y :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd F11.f11_x -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} f11f :: forall {p}. p -> Integer -> Integer [GblId, Arity=2, Str=<A><SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}] -f11f = \ (@p) _ [Occ=Dead] -> F11.f11f1 +f11f = \ (@p) (z [Occ=Dead] :: p) -> F11.f11f1 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.f5 :: Integer ===================================== testsuite/tests/arityanal/should_compile/Arity14.stderr ===================================== @@ -14,7 +14,7 @@ F14.f2 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/3} f14 :: forall {t}. (Ord t, Num t) => t -> t -> t -> t -[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 270 0 0] 310 0}] +[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 270 0 0] 350 0}] f14 = \ (@t) ($dOrd :: Ord t) ($dNum :: Num t) (eta :: t) (eta1 :: t) -> let { ===================================== testsuite/tests/deSugar/should_compile/T16615.stderr ===================================== @@ -9,7 +9,7 @@ g :: Int -> Bool [LclIdX, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [0] 120 10}] + Guidance=IF_ARGS [0] 140 10}] g = \ (i :: Int) -> case == @Int GHC.Internal.Classes.$fEqInt i (GHC.Internal.Types.I# 0#) @@ -23,7 +23,7 @@ f [Occ=LoopBreaker] :: Int -> Bool [LclIdX, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [0] 120 10}] + Guidance=IF_ARGS [0] 140 10}] f = \ (i :: Int) -> case == @Int GHC.Internal.Classes.$fEqInt i (GHC.Internal.Types.I# 0#) ===================================== testsuite/tests/dmdanal/should_compile/T23398.stderr ===================================== @@ -10,7 +10,7 @@ foo :: forall a. PairDict a => a -> a -> String Str=<SP(SP(1C(1,C(1,L)),A),SP(A,1C(1,L),A))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [90 0 0] 180 0}] + Guidance=IF_ARGS [90 0 0] 210 0}] foo = \ (@a) ($dCTuple2 :: PairDict a) (eta :: a) (eta1 :: a) -> case == ===================================== testsuite/tests/ghci.debugger/scripts/break021.stdout ===================================== @@ -41,7 +41,7 @@ _result :: IO () = _ ^^^^^^^^^^^^^^^^^ 13 in_another_module 0 Stopped in Main.in_another_decl, break020.hs:(6,21)-(7,30) -_result :: IO () = _ +_result :: m () = _ 5 vv 6 in_another_decl _ = do line1 0 @@ -49,25 +49,25 @@ _result :: IO () = _ ^^ 8 Stopped in Main.in_another_decl, break020.hs:6:24-30 -_result :: IO () = _ +_result :: m () = _ 5 6 in_another_decl _ = do line1 0 ^^^^^^^ 7 line2 0 Stopped in Main.line1, break020.hs:3:11-19 -_result :: IO () = _ +_result :: m () = _ 2 3 line1 _ = return () ^^^^^^^^^ 4 line2 _ = return () Stopped in Main.in_another_decl, break020.hs:7:24-30 -_result :: IO () = _ +_result :: m () = _ 6 in_another_decl _ = do line1 0 7 line2 0 ^^^^^^^ 8 Stopped in Main.line2, break020.hs:4:11-19 -_result :: IO () = _ +_result :: m () = _ 3 line1 _ = return () 4 line2 _ = return () ^^^^^^^^^ ===================================== testsuite/tests/profiling/should_run/T27225.stdout ===================================== @@ -1,7 +1,4 @@ -Cost-centre stack backtrace: - GHC.Internal.TopHandler.runMainIO1 (<no location info>) Main.Main.main (T27225.hs:23:1-4) Main.Main.top (T27225.hs:19:1-3) Main.Main.middle (T27225.hs:15:1-6) Main.Main.bottom (T27225.hs:9:1-6) - ===================================== testsuite/tests/profiling/should_run/T27225b.stdout ===================================== @@ -1,7 +1,4 @@ -Cost-centre stack backtrace: - GHC.Internal.TopHandler.runMainIO1 (<no location info>) Main.Main.main (T27225b.hs:29:1-4) Main.Main.top (T27225b.hs:25:1-3) Main.Main.middle (T27225b.hs:21:1-6) Main.Main.bottom (T27225b.hs:15:1-6) - ===================================== testsuite/tests/profiling/should_run/all.T ===================================== @@ -208,8 +208,13 @@ test('ignore_scc', [grep_prof("ignore_scc.hs"), test_opts_dot_prof], compile_and test('T21446', [], makefile_test, ['T21446']) -test('T27225', [only_ways(['prof'])], compile_and_run, ['-O']) -test('T27225b', [only_ways(['prof'])], compile_and_run, ['-O']) +# Only check the user-written cost centres: which library frames (runMainIO1, +# collectBacktraces', ...) show up depends on inlining and on whether the +# libraries were built with -fprof-late. +test('T27225', [only_ways(['prof']), filter_stdout_lines(r'.*Main\.Main\..*')], + compile_and_run, ['-O']) +test('T27225b', [only_ways(['prof']), filter_stdout_lines(r'.*Main\.Main\..*')], + compile_and_run, ['-O']) test('scc-prof-overloaded001', [grep_prof("scc-prof-overloaded001.hs"), test_opts_dot_prof], ===================================== testsuite/tests/simplCore/should_compile/T15205.stderr ===================================== @@ -10,7 +10,7 @@ f :: forall a b. C a b => a -> b Str=<1P(A,1C(1,C(1,L)))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [90 0] 40 0}] + Guidance=IF_ARGS [90 0] 50 0}] f = \ (@a) (@b) ($dC :: C a b) (eta :: a) -> op @a @b $dC eta eta ===================================== testsuite/tests/simplCore/should_compile/T26117.stderr ===================================== @@ -6,83 +6,7 @@ T26117.hs:17:10: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)] ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 196, types: 296, coercions: 2, joins: 0/0} - --- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} -op1 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int -[GblId[ClassOp], - Arity=1, - Str=<S!P(SL,A)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> - case v of { T26117.C:C v2 [Occ=Once1] _ [Occ=Dead] -> v2 }}] -op1 - = \ (@a) (@b) (v :: C a b) -> - case v of v1 { T26117.C:C v2 v3 -> v2 } - --- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} -op2 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int -[GblId[ClassOp], - Arity=1, - Str=<S!P(A,SL)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> - case v of { T26117.C:C _ [Occ=Dead] v3 [Occ=Once1] -> v3 }}] -op2 - = \ (@a) (@b) (v :: C a b) -> - case v of v1 { T26117.C:C v2 v3 -> v3 } - --- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} -T26117.$p1D [InlPrag=[~]] :: forall a b. D a b => Eq (F a) -[GblId[ClassOp], - Arity=1, - Str=<S!P(SL,A,A)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> - case v of { T26117.C:D v2 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] -> - v2 - }}] -T26117.$p1D - = \ (@a) (@b) (v :: D a b) -> - case v of v1 { T26117.C:D v2 v3 v4 -> v2 } - --- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} -dop1 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b -[GblId[ClassOp], - Arity=1, - Str=<S!P(A,SL,A)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> - case v of { T26117.C:D _ [Occ=Dead] v3 [Occ=Once1] _ [Occ=Dead] -> - v3 - }}] -dop1 - = \ (@a) (@b) (v :: D a b) -> - case v of v1 { T26117.C:D v2 v3 v4 -> v3 } - --- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} -dop2 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b -[GblId[ClassOp], - Arity=1, - Str=<S!P(A,A,SL)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> - case v of { T26117.C:D _ [Occ=Dead] _ [Occ=Dead] v4 [Occ=Once1] -> - v4 - }}] -dop2 - = \ (@a) (@b) (v :: D a b) -> - case v of v1 { T26117.C:D v2 v3 v4 -> v4 } + = {terms: 153, types: 148, coercions: 2, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T26117.$fCaList1 :: GHC.Internal.Prim.Addr# @@ -92,28 +16,6 @@ T26117.$fCaList1 :: GHC.Internal.Prim.Addr# Guidance=IF_ARGS [] 70 0}] T26117.$fCaList1 = "T26117.hs:17:10-37|\CANop2\EM"# --- RHS size: {terms: 6, types: 15, coercions: 0, joins: 0/0} -T26117.$fCaList_$cop2 [InlPrag=[2]] - :: forall a b. (Eq (F a), D a b) => F a -> a -> [b] -> Int -[GblId, - Arity=2, - Str=<B><B>b, - Cpr=b, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) - Tmpl= \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> - GHC.Internal.Control.Exception.Base.noMethodBindingError - @GHC.Internal.Types.LiftedRep - @(F a -> a -> [b] -> Int) - T26117.$fCaList1}] -T26117.$fCaList_$cop2 - = \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> - GHC.Internal.Control.Exception.Base.noMethodBindingError - @GHC.Internal.Types.LiftedRep - @(F a -> a -> [b] -> Int) - T26117.$fCaList1 - -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T26117.$fCaList3 :: Int [GblId, @@ -130,11 +32,48 @@ T26117.$fCaList2 :: Int Guidance=IF_ARGS [] 10 10}] T26117.$fCaList2 = GHC.Internal.Types.I# 3# +-- RHS size: {terms: 16, types: 16, coercions: 0, joins: 0/0} +T26117.$fCaList_$cop1 + :: forall a b. (Eq (F a), D a b) => F a -> a -> [b] -> Int +[GblId, + Arity=5, + Str=<1P(1C(1,C(1,L)),A)><A><L><A><A>, + Cpr=1, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=5,unsat_ok=True,boring_ok=False) + Tmpl= \ (@a) + (@b) + ($dEq [Occ=Once1] :: Eq (F a)) + ($dD [Occ=Dead] :: D a b) + (x :: F a) + (ds [Occ=Dead] :: a) + (ds1 [Occ=Dead] :: [b]) -> + case == @(F a) $dEq x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + }}] +T26117.$fCaList_$cop1 + = \ (@a) + (@b) + ($dEq :: Eq (F a)) + ($dD [Occ=Dead, OS=OneShot] :: D a b) + (x :: F a) + (ds [Occ=Dead] :: a) + (ds1 [Occ=Dead] :: [b]) -> + case == @(F a) $dEq x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + } + -- RHS size: {terms: 8, types: 7, coercions: 2, joins: 0/0} lvl :: forall b. F Int -> Int -> [b] -> Int -[GblId, Arity=3, Str=<1A><A><A>, Cpr=1, Unf=OtherCon []] +[GblId, Arity=3, Str=<SL><A><A>, Cpr=1, Unf=OtherCon []] lvl - = \ (@b) (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + = \ (@b) + (x :: F Int) + (ds [Occ=Dead] :: Int) + (ds1 [Occ=Dead] :: [b]) -> case x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool) of lwild { __DEFAULT -> T26117.$fCaList2 @@ -164,7 +103,7 @@ T26117.$fCaList_$s$fCaList [InlPrag=CONLIKE] Unf=DFun: \ (@b) ($dD :: D Int b) -> T26117.C:C TYPE: Int TYPE: [b] - \ (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + \ (x :: F Int) (ds [Occ=Dead] :: Int) (ds1 [Occ=Dead] :: [b]) -> case GHC.Internal.Prim.dataToTagSmall# @GHC.Internal.Types.Lifted @Bool @@ -187,19 +126,10 @@ T26117.$fCaList_$s$fCaList [InlPrag=CONLIKE] @GHC.Internal.Types.LiftedRep @(F Int -> Int -> [b] -> Int) "T26117.hs:17:10-37|\CANop2\EM"#] -T26117.$fCaList_$s$fCaList = \ (@b) _ [Occ=Dead] -> lvl2 @b - --- RHS size: {terms: 4, types: 9, coercions: 0, joins: 0/0} -lvl3 :: forall b a. F a -> a -> [b] -> Int -[GblId, Str=b, Cpr=b] -lvl3 - = \ (@b) (@a) -> - GHC.Internal.Control.Exception.Base.noMethodBindingError - @GHC.Internal.Types.LiftedRep - @(F a -> a -> [b] -> Int) - T26117.$fCaList1 +T26117.$fCaList_$s$fCaList + = \ (@b) ($dD [Occ=Dead] :: D Int b) -> lvl2 @b --- RHS size: {terms: 18, types: 21, coercions: 0, joins: 0/0} +-- RHS size: {terms: 10, types: 20, coercions: 0, joins: 0/0} T26117.$fCaList [InlPrag=CONLIKE] :: forall a b. (Eq (F a), D a b) => C a [b] [GblId[DFunId], @@ -208,225 +138,203 @@ T26117.$fCaList [InlPrag=CONLIKE] Unf=DFun: \ (@a) (@b) (v :: Eq (F a)) (v1 :: D a b) -> T26117.C:C TYPE: a TYPE: [b] - \ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> - case == @(F a) v x x of { - False -> T26117.$fCaList3; - True -> T26117.$fCaList2 - } - T26117.$fCaList_$cop2 @a @b v v1] + T26117.$fCaList_$cop1 @a @b v v1 + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1] T26117.$fCaList - = \ (@a) (@b) ($dEq :: Eq (F a)) _ [Occ=Dead] -> + = \ (@a) (@b) ($dEq :: Eq (F a)) ($dD :: D a b) -> T26117.C:C @a @[b] - (\ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> - case == @(F a) $dEq x x of { - False -> T26117.$fCaList3; - True -> T26117.$fCaList2 - }) - (lvl3 @b @a) + (T26117.$fCaList_$cop1 @a @b $dEq $dD) + (GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule4 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$trModule4 = "main"# +$trModule1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule3 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$trModule3 = GHC.Internal.Types.TrNameS T26117.$trModule4 +$trModule2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$trModule2 = GHC.Internal.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule2 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 30 0}] -T26117.$trModule2 = "T26117"# +$trModule3 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$trModule3 = "T26117"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule1 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$trModule1 = GHC.Internal.Types.TrNameS T26117.$trModule2 +$trModule4 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$trModule4 = GHC.Internal.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule :: GHC.Internal.Types.Module -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$trModule - = GHC.Internal.Types.Module T26117.$trModule3 T26117.$trModule1 +T26117.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module +[GblId, Unf=OtherCon []] +T26117.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} $krep :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] $krep = GHC.Internal.Types.KindRepFun - GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint + GHC.Internal.Types.KindRepType GHC.Internal.Types.KindRepConstraint -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +$krep1 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -T26117.$tcC1 - = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* $krep +$krep1 + = GHC.Internal.Types.KindRepFun + GHC.Internal.Types.KindRepType $krep -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$krep1 :: GHC.Internal.Types.KindRep +$krep2 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep1 = GHC.Internal.Types.KindRepVar 1# +$krep2 = GHC.Internal.Types.KindRepVar 1# -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep2 :: GHC.Internal.Types.KindRep +$krep3 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep2 = GHC.Internal.Types.KindRepFun $krep1 $krep1 +$krep3 = GHC.Internal.Types.KindRepFun $krep2 $krep2 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$krep3 :: GHC.Internal.Types.KindRep +$krep4 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep3 = GHC.Internal.Types.KindRepVar 0# +$krep4 = GHC.Internal.Types.KindRepVar 0# -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep4 :: GHC.Internal.Types.KindRep +$krep5 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep4 = GHC.Internal.Types.KindRepFun $krep3 $krep2 +$krep5 = GHC.Internal.Types.KindRepFun $krep4 $krep3 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$tcD2 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$tcD2 = "D"# +$tcD1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$tcD1 = "D"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$tcD1 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$tcD1 = GHC.Internal.Types.TrNameS T26117.$tcD2 +$tcD2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$tcD2 = GHC.Internal.Types.TrNameS $tcD1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T26117.$tcD :: GHC.Internal.Types.TyCon -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] +T26117.$tcD [InlPrag=[~]] :: GHC.Internal.Types.TyCon +[GblId, Unf=OtherCon []] T26117.$tcD = GHC.Internal.Types.TyCon 18427868686024955676#Word64 4087453451394481638#Word64 T26117.$trModule - T26117.$tcD1 + $tcD2 0# - T26117.$tcC1 + $krep1 -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -$krep5 :: [GHC.Internal.Types.KindRep] +$krep6 :: [GHC.Internal.Types.KindRep] [GblId, Unf=OtherCon []] -$krep5 +$krep6 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep - $krep1 + $krep2 (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep) -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} -$krep6 :: [GHC.Internal.Types.KindRep] +$krep7 :: [GHC.Internal.Types.KindRep] [GblId, Unf=OtherCon []] -$krep6 - = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep3 $krep5 +$krep7 + = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep4 $krep6 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep7 :: GHC.Internal.Types.KindRep +$krep8 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep7 = GHC.Internal.Types.KindRepTyConApp T26117.$tcD $krep6 +$krep8 = GHC.Internal.Types.KindRepTyConApp T26117.$tcD $krep7 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep8 :: GHC.Internal.Types.KindRep +$krep9 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep8 = GHC.Internal.Types.KindRepFun $krep4 $krep7 +$krep9 = GHC.Internal.Types.KindRepFun $krep5 $krep8 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +$krep10 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -T26117.$tc'C:D1 = GHC.Internal.Types.KindRepFun $krep4 $krep8 +$krep10 = GHC.Internal.Types.KindRepFun $krep5 $krep9 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D3 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$tc'C:D3 = "'C:D"# +$tc'C:D1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$tc'C:D1 = "'C:D"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D2 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$tc'C:D2 = GHC.Internal.Types.TrNameS T26117.$tc'C:D3 +$tc'C:D2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$tc'C:D2 = GHC.Internal.Types.TrNameS $tc'C:D1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D :: GHC.Internal.Types.TyCon -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] +T26117.$tc'C:D [InlPrag=[~]] :: GHC.Internal.Types.TyCon +[GblId, Unf=OtherCon []] T26117.$tc'C:D = GHC.Internal.Types.TyCon 14714477993590114477#Word64 17388374250742016296#Word64 T26117.$trModule - T26117.$tc'C:D2 + $tc'C:D2 2# - T26117.$tc'C:D1 + $krep10 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC3 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$tcC3 = "C"# +$tcC1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$tcC1 = "C"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC2 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$tcC2 = GHC.Internal.Types.TrNameS T26117.$tcC3 +$tcC2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$tcC2 = GHC.Internal.Types.TrNameS $tcC1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC :: GHC.Internal.Types.TyCon -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] +T26117.$tcC [InlPrag=[~]] :: GHC.Internal.Types.TyCon +[GblId, Unf=OtherCon []] T26117.$tcC = GHC.Internal.Types.TyCon 6116531860557468422#Word64 17953227584944457497#Word64 T26117.$trModule - T26117.$tcC2 + $tcC2 0# - T26117.$tcC1 + $krep1 ------ Local rules for imported ids -------- +"USPEC $cop1 @Int @_" + forall (@b) ($dEq [Occ=Dead] :: Eq (F Int)) ($dD :: D Int b). + T26117.$fCaList_$cop1 @Int @b $dEq $dD + = \ (x :: F Int) (ds [Occ=Dead] :: Int) (ds1 [Occ=Dead] :: [b]) -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of a# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of b# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.==# a# b# of { + __DEFAULT -> GHC.Internal.Types.I# 4#; + 1# -> GHC.Internal.Types.I# 3# + } + } + } "USPEC $fCaList @Int @_" - forall (@b) ($dD :: D Int b) ($dEq :: Eq (F Int)). + forall (@b) ($dEq [Occ=Dead] :: Eq (F Int)) ($dD :: D Int b). T26117.$fCaList @Int @b $dEq $dD = T26117.$fCaList_$s$fCaList @b $dD View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cdafca20cdfb2fc05e54435c7fa93… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cdafca20cdfb2fc05e54435c7fa93… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/apk/unfold-dicts] 15 commits: Remove the call to hoistFlag from processCmdLineP
by Andreas Klebinger (＠AndreasK) 29 Sep '26

29 Sep '26

Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC Commits: 098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00 Remove the call to hoistFlag from processCmdLineP This call was undesirable because it was causing a reconstruction of the list of flag processors. Even relying on list fusion would not be sufficient because we want to replace the list with a data structure with faster lookups to address #25763. The removal is done in two moves: * We move CmdLineP to CmdLine.hs * Then we move the effect of hoisting to processArgs via a new function hoistEwM - - - - - e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Do not create duplicate flag processors for the -W flag This makes simpler implementing the command line parser with a trie map holding flag processors. If we were to allow duplicate flag processors for any flag, the trie map would need to be a multimap. - - - - - 3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Replace the list of flag processors with a trie map in `processArgs` Previously `GHC.Driver.CmdLine.findArg` was called for each command-line argument, doing a linear search on the list of flag processors each time. This was somewhat costly as the list of flag processor has near 2000 elements. A lookup with a trie map is faster in general, but the speed up is only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient times, so the amount of lookups piles up. This could happen in large projects with many units each having many dependencies. If only a module needs to be recompiled, the user still needs to wait for all of the flag parsing to complete. The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a 10x speed up when using the trie. The trie map is implemented in `GHC.Data.StringTrie`. The design is explained in Note [Processing command line argument fast] in GHC.Driver.Session. The commit also: * adds two property-based tests for trie map operations, * adds a benchmark of the command line parser, and * renames the predicate `arg_ok` to `valid_flag_suffix` to decide what flag processor should be used when there are multiple matching prefixes on a flag. Fixes #25763. - - - - - 5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00 Compile Word64{Map,Set} with -O2 always. This is the hottest code and even if we build GHC with -O0 otherwise -O2 pays off for these modules. Fixes #27814. - - - - - 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - 53eead15 by Wolfgang Jeltsch at 2026-09-24T20:12:03-04:00 Correct the documentation of `explicitUnits` Resolves #27787. - - - - - 35bf6f4b by Simon Jakobi at 2026-09-24T20:12:49-04:00 Remove stale specHeader bullet from Note [Don't make fillers for constraint types] The Note said that Specialise.specHeader also calls mkAbsentFiller. abfc224a27c removed that call: the specialiser no longer drops dead arguments at all, see Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise. Assisted-by: Claude Fable 5.1 - - - - - 1abef1ef by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the `mhu-closure` makefile - - - - - a79a68ea by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Make `ghci-multi` hide all unneeded packages - - - - - d6e72450 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the definition of the home unit closure property - - - - - c9a2766d by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Re-implement the home unit closure check Compared to the previous implementation, the new one has the following advantages: * It is correct. - It distinguishes between units that have the same unit ID but different ABI hashes. - When `-hide-all-packages` is not used, it considers as home unit dependencies also units that are made implicitly available because they are in the package database. * It seems to be faster in usual settings. - In particular, it does not have a preparation phase in which it merges the dependency information from all home units, so that its running time does not grow linearly with the size of the package database in normal Cabal scenarios. * It is (hopefully) clearer. * It is better documented. - - - - - fa96acf8 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Remove erroneous GHC flag in `hadrian-multi` The flag was `-Werror=-Wno-error=incomplete-record-selectors`. Its purpose was to permit incomplete record selectors, but because of the illegal combination of `-Werror=` and `-Wno-error` it was ignored, without any negative consequences. - - - - - 9f48a5b9 by Alan Zimmerman at 2026-09-25T17:02:50-04:00 EPA: Add specific layout field to AnnList Up to now AnnList has effectively served to represent lists of things having layout, regardless of whether they do or not. In Haskell, layout is optional in many places, as there is also an alternative syntax using braces and semi-colons, which is free-form. This commit introduces AnnListLayout, a data structure capturing this distinction. It is deliberately set up similarly to EpLayout, so that these two can be merged in time. The transition is done mechanically, where AnnListBraces is not used yet, the original Nothing case maps to AnnListNoLayout, and the Just case to AnnListLayout. Later commits will fine tune these against the actual parser layout. - - - - - 5cdafca2 by Andreas Klebinger at 2026-09-29T17:50:24+00:00 Tweak inlining discout for unary class ops. Correctly account for arguments applied to the result of the class op application when computing rhs size for unary classes. I also fixed handling of casts/ticks while in the area. Fixes #27802 Fixes #27818 ------------------------- Metric Decrease: CoOpt_Singletons Metric Increase: T12234 T21839c T21839r T5321FD T5321Fun ------------------------- - - - - - 66 changed files: - .gitlab-ci.yml - + changelog.d/25763-cmdline-opt - + changelog.d/26610 - + changelog.d/T27802-classop-arg-size - + changelog.d/T27818-unfolding-size-casts-ticks - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Unfold.hs - + compiler/GHC/Data/StringTrie.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Data/Word64Set/Internal.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - ghc/GHC/Driver/Session/Mode.hs - hadrian/ghci-multi-cabal.in - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/driver/all.T - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout - + testsuite/tests/driver/stringtrie.hs - + testsuite/tests/driver/stringtrie.stdout - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - + testsuite/tests/perf/compiler/T25763.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr - testsuite/tests/warnings/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aed7066985d8cea9c236ac95c98e6f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aed7066985d8cea9c236ac95c98e6f… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/hsmodulename] 19 commits: Improvements to type/data family handling
by Rodrigo Mesquita (＠alt-romes) 29 Sep '26

29 Sep '26

Rodrigo Mesquita pushed to branch wip/romes/hsmodulename at Glasgow Haskell Compiler / GHC Commits: 1b4a622f by sheaf at 2026-09-17T02:39:13-04:00 Improvements to type/data family handling This commit makes several improvements to the treatment of type and data families in GHC: - We consistently use "type family" instead of "type synonym family" to avoid a confusion with type synonyms. For example: - OpenSynFamilyTyCon ==> OpenTypeFamilyTyCon - ClosedSynFamilyTyCon => ClosedTypeFamilyTyCon - Various functions that were specific to data families have been renamed to make this clear. For example: - tyConFamInst_maybe ==> tyConDataFamInst_maybe - isFamInstTyCon ==> isDataFamInstTyCon - 'FamTyConFlav' has been refactored so that all closed type families share a single 'ClosedTypeFamilyTyCon' constructor. The corresponding 'IfaceFamTyConFlav' type was updated similarly. This is then used to tidy up the implementation of GHC.Core.FamInstEnv.reduceTyFamApp_maybe. - - - - - c5aa9098 by sheaf at 2026-09-17T02:39:13-04:00 Small refactor of lookupFamInstEnv This commit reworks the code for looking up family instances in GHC.Core.FamInstEnv, reducing duplication a little bit. No change in behaviour. - - - - - a3ad4588 by sheaf at 2026-09-17T02:39:14-04:00 Use a type family for boxing unboxed types This commit overhauls the way in which unboxed types are boxed, as per the updated Note [Boxing constructors] in GHC.Builtin.WiredIn.Types.Box. The main change is to allow boxing to be parametrised by representation, e.g. making 'Box ty' a valid type. We achieve this by implementing 'Box' using a closed type family: newtype Box (a :: TYPE r) = Box (BoxTF r) type BoxTF :: RuntimeRep -> Type type family BoxTF r where BoxTF IntRep = BoxInt BoxTF Int8Rep = BoxInt8 BoxTF WordRep = BoxWord BoxTF LiftedRep = Any @Type BoxTF (TupleRep [r1, r2]) = (BoxTF r1, BoxTF r2) ... BoxTF (SumRep rs) = BoxSum rs This new design solves the following problems: - It allows boxing a type whose 'RuntimeRep' has not yet been determined (e.g. because we only learn the 'RuntimeRep' after constraint solving). That is, 'Box @r a' is a perfectly valid type even if 'r' is an unfilled metavariable. This is a requirement to fix #25065 (in which we need to box a type whose 'RuntimeRep' is only filled in during constraint solving). - It handles boxing of unboxed tuples and unboxed sums, via recursive boxing. See Note [Boxing TupleRep and SumRep] in GHC.Builtin.WiredIn.Types.Box. 'Box', 'BoxTF' and all of the boxing data constructors are defined in a new 'ghc-internal' module, 'GHC.Internal.Box'. This module contains nothing but wired-in declarations, and GHC never loads its interface on account of a wired-in thing (GHC.Builtin.Modules.isWiredInOnlyModule); see Note [Loading instances for wired-in things] in GHC.Iface.Load. The individual boxing data constructors are deliberately left as an internal implementation detail, and not exported. The intended API is via the two new magic 'Id's: box :: forall {r} (a :: TYPE r). a -> Box a unbox :: forall {r} (a :: TYPE r). Box a -> a exported from 'GHC.PrimOps' (in 'ghc-experimental'). The old boxing data types (IntBox, WordBox, FloatBox, DoubleBox, DictBox) are no longer exported from base (CLC proposal #421). We use this new design to consistently desugar: - parallel comprehensions (GHC.HsToCore.ListComp.{deListComp,dsMcStmt}) - then/group/using statements (GHC.HsToCore.ListComp.{dsTransStmt,dsMcStmt}) - recursive do blocks (mdo/rec) (GHC.HsToCore.Expr.dsDo) - arrows (GHC.HsToCore.Arrows) by consistently using 'box'/'unbox' to deal with unboxed types being put into big tuples. We also adapt 'GHC.Tc.Gen.Match.{tcMcStmt,tcDoStmt}' to create fresh /representation-polymorphic/ type variables for the binders that we are going to put into a big tuple (previously, GHC only allowed lifted types in that position). These desugaring of box and unbox is explained in Note [Desugaring box & unbox] in GHC.Core.Make.Box. Roughly speaking, the desugaring looks like: box @r @ty e ==> K e unbox @r @ty e ==> case e of K x -> x where 'K' is the boxing data constructor at RuntimeRep 'r'. It's slightly more complicated than that in practice: we first need to insert a cast (see Note [The canonical type of a RuntimeRep]) using the new 'CanonicalProv' 'UnivCoProvenance', and unboxed tuples/sums need recursive logic explained in Note [box/unbox for unboxed tuples and sums], including a specific 'BoxSum' datatypes for unboxed sum (which also needed a wired-in type-level list indexing type family (!!)). The desugaring happens in two ways: - Occurrences of 'box'/'unbox' emitted by the typechecker are eliminated in the 'ds_app_var' case of GHC.HsToCore.Expr. - Other code that needs to box/unbox emits the appropriate code inline. This includes the big tuple machinery of GHC.Core.Make used by the desugarer (GHC.HsToCore.{Utils,Binds,Arrows,ListComp}) as well as the float-out pass (GHC.Core.Opt.SetLevels). Core Lint checks that no occurrence of 'box'/'unbox' survives desugaring. On the way, we overhaul the litany of big tuple functions by introducing data BigTupleLayout = BoxedElements | BareElements to distinguish the two kinds of "big tuples" that GHC routinely deals with; for example 'mkBigCoreVarTupSolo' becomes 'mkBigCoreVarTup BareElements'. All of this code is moved to the new module GHC.Core.Make.BigTuple. Fixes #20864 #22336 #22473 #25065 #27331 ------------------------- Metric Decrease: T9872a ------------------------- - - - - - 4cf7628a by Evgeny Malyshev at 2026-09-17T02:39:56-04:00 Fix the CompactionFailed documentation link to compact The old Haddock reference links into base instead of ghc-compact. Use an explicit URL because ghc-compact depends on base, not vice versa. Fixes #27558 Assisted-By: OpenAI Codex - - - - - 098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00 Remove the call to hoistFlag from processCmdLineP This call was undesirable because it was causing a reconstruction of the list of flag processors. Even relying on list fusion would not be sufficient because we want to replace the list with a data structure with faster lookups to address #25763. The removal is done in two moves: * We move CmdLineP to CmdLine.hs * Then we move the effect of hoisting to processArgs via a new function hoistEwM - - - - - e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Do not create duplicate flag processors for the -W flag This makes simpler implementing the command line parser with a trie map holding flag processors. If we were to allow duplicate flag processors for any flag, the trie map would need to be a multimap. - - - - - 3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Replace the list of flag processors with a trie map in `processArgs` Previously `GHC.Driver.CmdLine.findArg` was called for each command-line argument, doing a linear search on the list of flag processors each time. This was somewhat costly as the list of flag processor has near 2000 elements. A lookup with a trie map is faster in general, but the speed up is only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient times, so the amount of lookups piles up. This could happen in large projects with many units each having many dependencies. If only a module needs to be recompiled, the user still needs to wait for all of the flag parsing to complete. The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a 10x speed up when using the trie. The trie map is implemented in `GHC.Data.StringTrie`. The design is explained in Note [Processing command line argument fast] in GHC.Driver.Session. The commit also: * adds two property-based tests for trie map operations, * adds a benchmark of the command line parser, and * renames the predicate `arg_ok` to `valid_flag_suffix` to decide what flag processor should be used when there are multiple matching prefixes on a flag. Fixes #25763. - - - - - 5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00 Compile Word64{Map,Set} with -O2 always. This is the hottest code and even if we build GHC with -O0 otherwise -O2 pays off for these modules. Fixes #27814. - - - - - 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - 53eead15 by Wolfgang Jeltsch at 2026-09-24T20:12:03-04:00 Correct the documentation of `explicitUnits` Resolves #27787. - - - - - 35bf6f4b by Simon Jakobi at 2026-09-24T20:12:49-04:00 Remove stale specHeader bullet from Note [Don't make fillers for constraint types] The Note said that Specialise.specHeader also calls mkAbsentFiller. abfc224a27c removed that call: the specialiser no longer drops dead arguments at all, see Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise. Assisted-by: Claude Fable 5.1 - - - - - 1abef1ef by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the `mhu-closure` makefile - - - - - a79a68ea by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Make `ghci-multi` hide all unneeded packages - - - - - d6e72450 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the definition of the home unit closure property - - - - - c9a2766d by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Re-implement the home unit closure check Compared to the previous implementation, the new one has the following advantages: * It is correct. - It distinguishes between units that have the same unit ID but different ABI hashes. - When `-hide-all-packages` is not used, it considers as home unit dependencies also units that are made implicitly available because they are in the package database. * It seems to be faster in usual settings. - In particular, it does not have a preparation phase in which it merges the dependency information from all home units, so that its running time does not grow linearly with the size of the package database in normal Cabal scenarios. * It is (hopefully) clearer. * It is better documented. - - - - - fa96acf8 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Remove erroneous GHC flag in `hadrian-multi` The flag was `-Werror=-Wno-error=incomplete-record-selectors`. Its purpose was to permit incomplete record selectors, but because of the illegal combination of `-Werror=` and `-Wno-error` it was ignored, without any negative consequences. - - - - - 9f48a5b9 by Alan Zimmerman at 2026-09-25T17:02:50-04:00 EPA: Add specific layout field to AnnList Up to now AnnList has effectively served to represent lists of things having layout, regardless of whether they do or not. In Haskell, layout is optional in many places, as there is also an alternative syntax using braces and semi-colons, which is free-form. This commit introduces AnnListLayout, a data structure capturing this distinction. It is deliberately set up similarly to EpLayout, so that these two can be merged in time. The transition is done mechanically, where AnnListBraces is not used yet, the original Nothing case maps to AnnListNoLayout, and the Just case to AnnListLayout. Later commits will fine tune these against the actual parser layout. - - - - - 73eaa0ac by Rodrigo Mesquita at 2026-09-29T18:04:44+01:00 ttg: HsModuleName in the AST, ModuleName in GHC This commit makes the AST fully independent from GHC by parsing a "module name" as an `HsModuleName (= HText)` rather than constructing an `ModuleName (= FastString)` straight away. In the GHC side, everything remains as a `ModuleName`. We turn AST `HsModuleName`s into fast strings with the cheap `mkFastStringShortText` when we process the AST for manipulation within the compiler. There are no performance regressions introduced by this approach. This is the final piece of #21592 Alternative plans were discussed in gitlab.haskell.org/ghc/ghc/-/merge_requests/16546#note_694647, but the Simon suggested one won in simplicity and performance when compared against my attempt at implementing my original plan of having a family `ModuleNameP`. - - - - - 231 changed files: - .gitlab-ci.yml - + changelog.d/25763-cmdline-opt - + changelog.d/26610 - + changelog.d/boxing-family - + changelog.d/clc-421 - compiler/GHC.hs - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/Modules.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Builtin/WiredIn/Prim.hs - compiler/GHC/Builtin/WiredIn/TypeLits.hs - compiler/GHC/Builtin/WiredIn/Types.hs - + compiler/GHC/Builtin/WiredIn/Types/Box.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Show.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Axiom.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - + compiler/GHC/Core/Make/BigTuple.hs - + compiler/GHC/Core/Make/Box.hs - compiler/GHC/Core/Opt/CallerCC/Types.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - + compiler/GHC/Data/StringTrie.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Data/Word64Set/Internal.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs-boot - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Debug.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/CompleteMatch.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/TyThing/Ppr.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Module.hs - compiler/GHC/Unit/Module/Env.hs - + compiler/GHC/Unit/Module/Name.hs - compiler/GHC/Unit/Parser.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Unit/Types.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - compiler/Language/Haskell/Syntax/Text.hs - compiler/ghc.cabal.in - ghc/GHC/Driver/Session/Mode.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - hadrian/ghci-multi-cabal.in - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/include/RtsIfaceSymbols.h - + libraries/ghc-internal/src/GHC/Internal/Box.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - libraries/ghc-internal/src/GHC/Internal/Types.hs - linters/lint-codes/LintCodes/Static.hs - rts/Prelude.h - rts/include/rts/RtsToHsIface.h - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - rts/sm/Evac.c - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/arrows/should_run/all.T - + testsuite/tests/arrows/should_run/arrowrun005.hs - + testsuite/tests/arrows/should_run/arrowrun005.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/deSugar/should_compile/T25065a.hs - testsuite/tests/deSugar/should_compile/all.T - + testsuite/tests/deSugar/should_run/T20864.hs - + testsuite/tests/deSugar/should_run/T20864.stdout - + testsuite/tests/deSugar/should_run/T25065b.hs - + testsuite/tests/deSugar/should_run/T25065b.stdout - testsuite/tests/deSugar/should_run/all.T - testsuite/tests/driver/all.T - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout - + testsuite/tests/driver/stringtrie.hs - + testsuite/tests/driver/stringtrie.stdout - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - + testsuite/tests/indexed-types/should_run/T27331.hs - + testsuite/tests/indexed-types/should_run/T27331.stdout - + testsuite/tests/indexed-types/should_run/T27331b.hs - + testsuite/tests/indexed-types/should_run/T27331b.stdout - + testsuite/tests/indexed-types/should_run/T27331b_Plugin.hs - testsuite/tests/indexed-types/should_run/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - 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/notes.stdout - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - + testsuite/tests/perf/compiler/T25763.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs - + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr - testsuite/tests/warnings/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c603dbebc167a3520efe67867734c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c603dbebc167a3520efe67867734c… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/multi-threaded-debugger-p1] 4 commits: Build EvalOpts once per exec rather than per breakpoint stop
by Rodrigo Mesquita (＠alt-romes) 29 Sep '26

29 Sep '26

Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger-p1 at Glasgow Haskell Compiler / GHC Commits: aab472ba by Rodrigo Mesquita at 2026-09-22T11:54:27+01:00 Build EvalOpts once per exec rather than per breakpoint stop in interpreter_steplocal the allocations increased because now we're updating `eval_opts` after constructing them in `handleRunStatus` (which is run many times since in step-local most often we don't stop, just check). So drop the update to the eval_opts, and, in fact, pull their construction out. the loop always uses the same eval_opts, so no point in constructing them inside from scratch every time. -3.6% from this branch which had the regressions in interpreter_steplocal - - - - - a3ebc544 by Rodrigo Mesquita at 2026-09-22T16:20:35+01:00 Look up a thread's ResumeContext without taking a lock modifyMVar is unnecessarily expensive and blocking when most often we just care about reading without modifying. optimize for default case (thread context already exists). It is called every single time a breakpoint is hit (regardless of whether we stop there, e.g. in interpreter_steplocal we do not stop there often) - - - - - cd553e96 by Rodrigo Mesquita at 2026-09-22T18:15:21+01:00 Every thread resume-context keeps a var for its EvalStatus Kill the global mapping from thread id to EvalStatus Instead, keep the EvalStatus in the ResumeContext associated to a thread in the threadContextVar (where entries are created on breakpoints being hit and when writing an EvalComplete result) Before, every breakpoint hit meant reading the global map TVar and deleting a map entry which did a lot of allocations. Now, we have a Nothing variable which we overwrite to "take" rather than deleting from a Map and allocating the GlobalDbgMap too. Note that for every breakpoint hit we'd have to insert the ThreadId entry in the map again (because we deleted it last time we resumed), again allocating unnecessarily. Now it's only a look up on the map and an update on the variable directly. And a LOT of breakpoints were hit on interpreter_steplocal, stress testing the cost of hitting a breakpoint The isolated threads move to their own top-level TVar Set. - - - - - 64836f8c by Rodrigo Mesquita at 2026-09-23T16:18:18+01:00 Move whether a thread is isolated to the same global map Stops us from reconstructing the set every time this changed instead to being a per thread variable just toggled on/off, by default non-isolated like before (before it was Set.empty, Set.insert for True, Set.delete for FALSE). This is more straightforward -- there's always an isolation mode per thread and we can toggle it directly - - - - - 5 changed files: - compiler/GHC/Driver/Config.hs - compiler/GHC/Runtime/Eval.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/GHCi/Run/Breakpoints.hs Changes: ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -41,15 +41,15 @@ data EvalStep | EvalStepNone -- | Extract GHCi options from DynFlags and step -initEvalOpts :: DynFlags -> EvalStep -> EvalOpts -initEvalOpts dflags step = +initEvalOpts :: DynFlags -> EvalStep -> Bool -> EvalOpts +initEvalOpts dflags step isolate_breaks = EvalOpts { useSandboxThread = gopt Opt_GhciSandbox dflags , singleStep = singleStep , stepOut = stepOut , breakOnException = gopt Opt_BreakOnException dflags , breakOnError = gopt Opt_BreakOnError dflags - , isolateThreadBreaks = True + , isolateThreadBreaks = isolate_breaks -- Must opt-in to listening to all thread's breakpoints. -- (e.g. for running 'main' in a debugger) } ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -230,18 +230,16 @@ execStmt' stmt stmt_text ExecOptions{..} = do Just (ids, hval, fix_env) -> do updateFixityEnv fix_env - status <- - liftIO $ do - let eval_opts = (initEvalOpts idflags' (enableGhcStepMode execSingleStep)) - { isolateThreadBreaks = enableIsolateThreadBreaks execIsolateMode } - evalStmt interp eval_opts (execWrap hval) + let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep) + (enableIsolateThreadBreaks execIsolateMode) + status <- liftIO $ evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_gre_cache ic) size = ghciHistSize idflags' - handleRunStatus execSingleStep execIsolateMode stmt_text bindings ids + handleRunStatus execSingleStep eval_opts stmt_text bindings ids status (emptyHistory size) runDecls :: GhcMonad m => String -> m [TyThing] @@ -293,18 +291,22 @@ emptyHistory size = nilBL size -- or :stepmodule, rather than :step, we only care about certain breakpoints). handleRunStatus :: GhcMonad m => SingleStep - -> ThreadBreaksIsolationMode + -- ^ The kind of step we're doing. 'handleRunStatus' may resume + -- the evaluation automatically if the step kind indicates to + -- ignore this breakpoint (e.g. when doing 'ModuleStep' but the + -- breakpoint just hit belongs to a different module) + -> EvalOpts + -- ^ The evaluation options in case the evaluation is resumed. -> String -> ResumeBindings -> [Id] -> EvalStatus_ [ForeignHValue] [HValueRef] -> BoundedList History -> m ExecResult -handleRunStatus step isolateMode expr bindings final_ids status history0 = do +handleRunStatus step eval_opts expr bindings final_ids status history0 = do hsc_env <- getSession let interp = hscInterp hsc_env - dflags = hsc_dflags hsc_env case status of -- Completed successfully @@ -396,15 +398,13 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do return (ExecBreak break_ids (Just ibi) resume) else do -- resume with the same step type - let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) - { isolateThreadBreaks = enableIsolateThreadBreaks isolateMode } status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv history <- if not tracing then pure history0 else do history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 -- history is strict, otherwise our BoundedList is pointless. return history' - handleRunStatus step isolateMode expr bindings final_ids status history + handleRunStatus step eval_opts expr bindings final_ids status history where tracing | RunAndLogSteps <- step = True | otherwise = False @@ -452,8 +452,8 @@ resumeExec step isolateMode mbCnt r = do (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt _ -> return () - let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) - { isolateThreadBreaks = enableIsolateThreadBreaks isolateMode } + let eval_opts = initEvalOpts dflags (enableGhcStepMode step) + (enableIsolateThreadBreaks isolateMode) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist hug = hsc_HUG hsc_env @@ -464,7 +464,7 @@ resumeExec step isolateMode mbCnt r = do hist1 <- liftIO (mkHistory hug apStack bi) return $ hist1 `consBL` fromListBL 50 hist | otherwise -> pure prevHistoryLst - handleRunStatus step isolateMode expr bindings final_ids status =<< hist' + handleRunStatus step eval_opts expr bindings final_ids status =<< hist' setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 setupBreakpoint interp ibi cnt = do @@ -1274,7 +1274,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - let eval_opts = initEvalOpts dflags EvalStepNone + let eval_opts = initEvalOpts dflags EvalStepNone True status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -395,7 +395,7 @@ data EvalOpts , stepOut :: Bool , breakOnException :: Bool , breakOnError :: Bool - , isolateThreadBreaks :: Bool + , isolateThreadBreaks :: !Bool -- ^ If @isolateThreadBreaks == True@, any breakpoint hit by the thread -- forked~[1] to execute this expression is only seen by a caller observing -- this thread's result explicitly. That is, this thread's 'EvalStatus' can ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -405,10 +405,11 @@ sandboxIO opts io -- rather than just "main" being observed. This should be used for the main -- debuggee execution of a debugger. withBreakAction :: EvalOpts -> ThreadId -> (IO (EvalStatus [HValueRef]) -> IO a) -> IO a -withBreakAction opts tid@(ThreadId tid#) act - = bracket setBreakAction resetBreakAction (\_ -> act waitForResult) +withBreakAction opts tid@(ThreadId tid#) act = do + ctx <- getThreadResumeContext tid + bracket (setBreakAction ctx) (resetBreakAction ctx) (\_ -> act (waitForResult ctx)) where - setBreakAction = do + setBreakAction ctx = do poke breakPointIOAction globalBreakStablePtr -- TODO: This is poke thread unsafe, as one thread might be accessing this -- global variable while this thread tries to overwrite it. We should @@ -422,32 +423,34 @@ withBreakAction opts tid@(ThreadId tid#) act runIf# singleStep rts_enableStopNextBreakpoint runIf# stepOut rts_enableStopAfterReturn - runIf isolateThreadBreaks setIsolatedThread - resetBreakAction () = do + runIfCtx ctx isolateThreadBreaks setIsolatedCtx + + resetBreakAction ctx () = do poke exceptionFlag 0 rts_disableStopAfterReturn tid# rts_disableStopNextBreakpoint tid# - runIf isolateThreadBreaks unsetIsolatedThread + runIfCtx ctx isolateThreadBreaks unsetIsolatedCtx -- freeStablePtr stablePtr TODO: we never free the global stablePtr for -- global action. Maybe we should have a de-init for clean up. -- TODO: don't set it in `setBreakAction` either. Should be on -- interpreter initialization. - runIf pred what = when (pred opts) (what tid) - runIf# pred what = when (pred opts) (what tid#) + runIf pred what = when (pred opts) (what tid) + runIf# pred what = when (pred opts) (what tid#) + runIfCtx ctx pred what = when (pred opts) (what ctx) - waitForResult + waitForResult ctx | isolateThreadBreaks opts = atomically $ - readThreadEvalStatus tid + readCtxEvalStatus ctx | otherwise = atomically $ (EvalPaused <$> readAnyThreadEvalBreak) `orElse` - readThreadEvalStatus tid + readCtxEvalStatus ctx -- While we're waiting for the sandbox thread to return a result, if -- the current thread receives an asynchronous exception we re-throw ===================================== libraries/ghci/GHCi/Run/Breakpoints.hs ===================================== @@ -8,10 +8,12 @@ module GHCi.Run.Breakpoints -- * Per-thread breakpoints , readThreadEvalStatus, readAnyThreadEvalBreak , writeThreadEvalStatus + , readCtxEvalStatus, writeCtxEvalStatus -- ** Isolating thread breakpoints , withIsolatedThread , setIsolatedThread, unsetIsolatedThread + , setIsolatedCtx, unsetIsolatedCtx -- ** Querying the global thread breakpoint map , listOtherPausedThreads @@ -29,18 +31,15 @@ import GHCi.Message import GHCi.RemoteTypes import qualified Data.Map as Map -import qualified Data.Set as Set import Control.Concurrent import Control.Exception import qualified Data.ByteString.Short.Internal as BS -#if defined(PROFILING) -import GHC.Data.ShortByteString -#endif import GHC.Exts import GHC.Stack import Foreign hiding (void) import GHC.Conc.Sync import GHC.IO hiding ( bracket ) +import Control.Monad -------------------------------------------------------------------------------- -- * Global break action @@ -72,7 +71,7 @@ globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction globalBreakAction :: BreakpointCallback globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do tid <- myThreadId - ResumeContext{..} <- getThreadResumeContext tid + ctx@ResumeContext{..} <- getThreadResumeContext tid resume_r <- mkRemoteRef tid apStack_r <- mkRemoteRef apStack ccs <- toRemotePtr <$> getCCSOf apStack @@ -83,7 +82,7 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do info_mod <- BS.packCString (Ptr info_mod#) info_mod_uid <- BS.packCString (Ptr info_mod_uid#) pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) - writeThreadEvalStatus tid $ EvalBreak apStack_r mb_breakpoint resume_r ccs + writeCtxEvalStatus ctx $ EvalBreak apStack_r mb_breakpoint resume_r ccs -- Block until this thread is resumed (by the thread which took the -- `ResumeContext` from the `statusMVar`). @@ -109,14 +108,19 @@ globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do -- Succeeds when the given thread writes to the global debugger map an eval result. readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef]) readThreadEvalStatus tid = do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - case Map.lookup tid threadEvalStatuses of + ctxs <- readTVar threadContextsVar + case Map.lookup tid ctxs of + Just ctx -> readCtxEvalStatus ctx + Nothing -> retry -- to write a thread break or result, the + -- 'threadContextsVar' entry will be created + +-- | Like 'readThreadEvalStatus', but when the 'ResumeContext' is already +-- available (to avoid looking it up unnecessarily). +readCtxEvalStatus :: ResumeContext -> STM (EvalStatus [HValueRef]) +readCtxEvalStatus ResumeContext{resumeEvalStatus} = + readTVar resumeEvalStatus >>= \case Just r -> do - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it - , isolatedThreads - } + writeTVar resumeEvalStatus Nothing -- clear it pure r Nothing -> retry -- until someone writes the result for this thread @@ -128,36 +132,38 @@ readThreadEvalStatus tid = do -- Succeeds when any thread hits a breakpoint. readAnyThreadEvalBreak :: STM EvalBreak readAnyThreadEvalBreak = do - dbgs <- readTVar globalDbgStatusVar + ctxs <- readTVar threadContextsVar -- try reading any thread's 'EvalBreak' and retry if none have yielded one yet - foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs)) + foldr (\ctx next -> readBreak ctx `orElse` next) retry (Map.elems ctxs) where - readStatus GlobalDbgStatus{..} (tid, _) -- don't look at isolated threads - | Set.member tid isolatedThreads - = retry - - readStatus GlobalDbgStatus{..} (tid, status) - = do - case status of - EvalComplete{} -> retry -- successes can be read with `readThreadEvalStatus` - EvalPaused b -> do - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses = Map.delete tid threadEvalStatuses - , isolatedThreads - } - pure b + readBreak ResumeContext{resumeEvalStatus, resumeIsolated} = do + isolated <- readTVar resumeIsolated + if isolated + then retry -- don't look at isolated threads + else readTVar resumeEvalStatus >>= \case + Just (EvalPaused b) -> do + writeTVar resumeEvalStatus Nothing + pure b + Just EvalComplete{} -> + retry -- successes can be read with `readThreadEvalStatus` + Nothing -> + retry -- no status for this thread yet writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO () -writeThreadEvalStatus tid status = +writeThreadEvalStatus tid status = do + -- get or create a 'ResumeContext' for the thread (e.g. we may write the + -- EvalComplete without breakpoints occurring, so the map won't have an entry): + ctx <- getThreadResumeContext tid + writeCtxEvalStatus ctx status + +-- | Like 'writeThreadEvalStatus', but for when the 'ResumeContext' is already +-- available +writeCtxEvalStatus :: ResumeContext -> EvalStatus [HValueRef] -> IO () +writeCtxEvalStatus ResumeContext{resumeEvalStatus} status = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar $ - GlobalDbgStatus - { threadEvalStatuses = - Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") - tid status threadEvalStatuses - , isolatedThreads } + readTVar resumeEvalStatus >>= \case + Just{} -> error "writeCtxEvalStatus: should be impossible" + Nothing -> writeTVar resumeEvalStatus (Just status) -- ** Isolating thread breakpoints --------------------------------------------- @@ -174,23 +180,15 @@ withIsolatedThread tid = bracket_ (setIsolatedThread tid) (unsetIsolatedThread t -- expression to run should not be seen at all by the debugger (e.g. when -- evaluating an expr to :force a variable) setIsolatedThread :: ThreadId -> IO () -setIsolatedThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , isolatedThreads = Set.insert tid isolatedThreads - } +setIsolatedThread = getThreadResumeContext >=> setIsolatedCtx -- | Undoes 'setIsolatedThread' unsetIsolatedThread :: ThreadId -> IO () -unsetIsolatedThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , isolatedThreads = Set.delete tid isolatedThreads - } +unsetIsolatedThread = getThreadResumeContext >=> unsetIsolatedCtx + +setIsolatedCtx, unsetIsolatedCtx :: ResumeContext -> IO () +setIsolatedCtx ctx = atomically $ writeTVar (resumeIsolated ctx) True +unsetIsolatedCtx ctx = atomically $ writeTVar (resumeIsolated ctx) False -- ** Querying the global thread breakpoint map -------------------------------- @@ -201,64 +199,74 @@ unsetIsolatedThread tid = atomically $ do -- the global thread mapping) and are asking about which other threads are -- paused to list them. listOtherPausedThreads :: IO [ThreadId] -listOtherPausedThreads = do - m <- atomically $ readTVar globalDbgStatusVar - pure $ Map.keys $ Map.filter isBreak (threadEvalStatuses m) +listOtherPausedThreads = atomically $ do + ctxs <- readTVar threadContextsVar + paused <- mapM isBreak (Map.toList ctxs) + pure [tid | (tid, True) <- paused] where - isBreak EvalBreak{} = True - isBreak EvalComplete{} = False - --- ** Global thread exec status map -------------------------------------------- - --- | When we launch a new thread using the debugger, we map ... TODO ... all --- threads launched by that main stmt may further spawn threads, and any of --- them might hit a breakpoint (break array toggled, or per-thread step in --- might be used, or pause button, etc...). --- --- When we launch that main thread we also write its result to this map. So --- this map will only contain the results of threads we explicitly care to --- observe the result of. Not all threads will write their results here, --- certainly not ones spawned unknowningly by the main stmt. --- ... --- todo words -globalDbgStatusVar :: TVar GlobalDbgStatus -globalDbgStatusVar = unsafePerformIO $ newTVarIO $ GlobalDbgStatus Map.empty Set.empty -{-# NOINLINE globalDbgStatusVar #-} - -data GlobalDbgStatus = GlobalDbgStatus - { threadEvalStatuses :: !(Map.Map ThreadId (EvalStatus [HValueRef])) - -- ^ Whenever a thread hits a breakpoint it inserts in this map its 'EvalBreak'. - -- We can additionally observe a thread's result by calling - -- `writeThreadEvalStatus tid (EvalComplete ...)` when the main expression - -- finishes evaluating, see e.g. 'sandboxIO'. - , isolatedThreads :: !(Set.Set ThreadId) - -- ^ Threads in this map are meant to be ignored by 'readAnyThreadEvalBreak'. - -- That is, even if one of the threads in this set hits a breakpoint, we - -- can only read its 'EvalBreak' with @'readThreadEvalStatus' tid@ directly. - } + isBreak (tid, ResumeContext{resumeEvalStatus}) = do + status <- readTVar resumeEvalStatus + pure (tid, case status of + Just EvalBreak{} -> True + Just EvalComplete{} -> False + Nothing -> False) -------------------------------------------------------------------------------- -- * Per-thread resume-ing -------------------------------------------------------------------------------- getThreadResumeContext :: ThreadId -> IO ResumeContext -getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do - case Map.lookup tid gbm0 of +getThreadResumeContext tid = do + ctxs0 <- readTVarIO threadContextsVar + case Map.lookup tid ctxs0 of + Just ctx -> pure ctx -- common case: hence read without transaction Nothing -> do - r <- ResumeContext <$> newEmptyMVar - let !gbm1 = Map.insert tid r gbm0 - pure (gbm1, r) - Just ctx -> do - pure (gbm0, ctx) + new_ctx <- ResumeContext <$> newEmptyMVar + <*> newTVarIO Nothing + <*> newTVarIO False + atomically $ do -- write new thread context atomically + ctxs1 <- readTVar threadContextsVar + case Map.lookup tid ctxs1 of + Just ctx -> pure ctx -- already exists + Nothing -> do + let !ctxs2 = Map.insert tid new_ctx ctxs1 + writeTVar threadContextsVar ctxs2 + pure new_ctx --- | A global mapping from thread ids to the MVars on which they block when stopped. -globalBreakActionMap :: MVar (Map.Map ThreadId ResumeContext) -globalBreakActionMap = unsafePerformIO $ newMVar Map.empty -{-# NOINLINE globalBreakActionMap #-} +-- | A global mapping from threads to their per-thread state 'ResumeContext' +-- (that e.g. contain the MVars on which they block when stopped) +threadContextsVar :: TVar (Map.Map ThreadId ResumeContext) +threadContextsVar = unsafePerformIO $ newTVarIO Map.empty +{-# NOINLINE threadContextsVar #-} -newtype ResumeContext = ResumeContext - { resumeBreakMVar :: MVar () +-- | Global context for a thread, which is created and inserted in the global +-- 'threadContextsVar' when a thread hits a breakpoint (and, thus, the +-- 'globalBreakAction') is run, or when 'withBreakAction' sets the thread +-- isolation (e.g. in 'sandboxIO'), or in other calls to +-- 'getThreadResumeContext', the function which gets or creates a thread +-- 'ResumeContext'. +-- +-- TODO: Rename ResumeContext to something like ThreadContext or +-- ThreadDbgContext or (Thread)BreakContext, and fields to something like +-- dbgEvalStatus, threadIsolated, ... +data ResumeContext = ResumeContext + { resumeBreakMVar :: !(MVar ()) -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar - -- (gotten from the 'globalBreakActionMap'). + -- (gotten from the 'threadContextsVar'). -- The debugger can unblock that thread by signaling its MVar. + , resumeEvalStatus :: !(TVar (Maybe (EvalStatus [HValueRef]))) + -- ^ When a thread hits a breakpoint, the 'globalBreakAction' is run and + -- writes an 'EvalBreak' in this @TVar@ (which was found in 'threadContextsVar'). + -- + -- Additionally, the 'EvalComplete' result of a thread may be written here + -- using `writeThreadEvalStatus tid (EvalComplete ...)` after the main + -- expression finishes evaluating, see e.g. 'sandboxIO'. + -- + -- The variable should be emptied (i.e. set to 'Nothing') by whoever + -- reads the status. + , resumeIsolated :: !(TVar Bool) + -- ^ When set, this thread is meant to be ignored by 'readAnyThreadEvalBreak'. + -- That is, if a thread with resumeIsolated=True hits a breakpoint, its + -- 'EvalBreak' can only be read with @'readThreadEvalStatus' tid@ for this + -- thread's @tid@ directly. } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0876759757f2ef4c2e8d7ea2de65e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0876759757f2ef4c2e8d7ea2de65e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/27641] Don't `:add` modules the loader will reject
by Hannes Siebenhandl (＠fendor) 29 Sep '26

29 Sep '26

Hannes Siebenhandl pushed to branch wip/fendor/27641 at Glasgow Haskell Compiler / GHC Commits: d863b814 by Hannes Siebenhandl at 2026-09-29T17:12:34+02:00 Don't `:add` modules the loader will reject Only home modules can be actually added to the loader context, thus we only accept the module if it belongs to a home unit. - - - - - 3 changed files: - + changelog.d/27641 - ghc/GHCi/UI.hs - testsuite/tests/ghci/scripts/T27641.stderr Changes: ===================================== changelog.d/27641 ===================================== @@ -0,0 +1,4 @@ +section: ghci +synopsis: Don't accept modules in `:add` that the loader will reject +issues: #27641 +mrs: !16734 ===================================== ghc/GHCi/UI.hs ===================================== @@ -180,6 +180,7 @@ import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) import qualified GHC.Unit.Module.Graph as GHC +import GHC.Unit.Home.Graph (memberHugUnit) ----------------------------------------------------------------------------- @@ -2400,7 +2401,9 @@ addModule files = do result <- liftIO $ Finder.findImportedModule hsc_env Finder.LookupUser m NoPkgQual case result of - Found _ _ -> return True + -- We could find a module from a dependency, such as `Data.List`, but we can't + -- actualy load that unless the module is located in a home unit. + Found _ m | moduleUnit m `memberHugUnit` hsc_HUG hsc_env -> return True _ -> do reportError (GhciModuleError $ GhciModuleNotFound (moduleNameString m)) return False ===================================== testsuite/tests/ghci/scripts/T27641.stderr ===================================== @@ -1,6 +1,2 @@ -<no location info>: error: [GHC-82272] - module ‘Data.List’ cannot be found locally - -<no location info>: error: [GHC-82272] - module ‘Data.List’ cannot be found locally +<interactive>: error: [GHCi-23305] Module Data.List not found View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d863b8144b87fcc5482ff20b1531970… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d863b8144b87fcc5482ff20b1531970… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0