June 2026 - ghc-commits

[Git][ghc/ghc][wip/sjakobi/T27368] testsuite: Add regression test for #27368
by Simon Jakobi (＠sjakobi2) 11 Jun '26

11 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27368 at Glasgow Haskell Compiler / GHC Commits: 4ff5d4da by Simon Jakobi at 2026-06-11T13:45:48+02:00 testsuite: Add regression test for #27368 The test distills the code shape that made setInfoTableStackMap panic when compiling GHC.CmmToAsm.Dwarf.Types with -O2 on top of !16168: two branches with identical suffixes from a three-constructor case onwards. Common block elimination merges the duplicated call blocks across the branches and leaves the losing copies unreachable in the block map, with a continuation label that is itself unreachable. Also panics unfixed released compilers (GHC 9.12.2 and 9.14.1). Co-Authored-By: Claude Fable 5 <noreply(a)anthropic.com> - - - - - 2 changed files: - + testsuite/tests/codeGen/should_compile/T27368.hs - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== testsuite/tests/codeGen/should_compile/T27368.hs ===================================== @@ -0,0 +1,20 @@ +-- Regression test for #27368: setInfoTableStackMap panicked because +-- callProcPoints collected the continuation of a call in an unreachable +-- block. The two branches below have identical suffixes from the inner +-- case onwards; common block elimination merges the duplicated call +-- blocks but leaves the losing copies in the block map, where the dead +-- call's continuation label is itself unreachable. +module T27368 (f) where + +{-# NOINLINE put #-} +put :: Int -> Int -> IO () +put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure () + +data T = N | J Int | K + +f :: Int -> Bool -> T -> IO () +f h a t = do + if a + then do put h 1; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + else do put h 2; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + put h 0 ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -150,3 +150,5 @@ test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppres test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +test('T27368', normal, compile, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ff5d4daff5bde31cd051aa1e5a6295… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ff5d4daff5bde31cd051aa1e5a6295… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/terrorjack/drop-long-reg
by Cheng Shao (＠TerrorJack) 11 Jun '26

11 Jun '26

Cheng Shao pushed new branch wip/terrorjack/drop-long-reg at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/terrorjack/drop-long-reg You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/external-unit-db-cache] WIP: Introduce UnitIndex for global data
by Hannes Siebenhandl (＠fendor) 11 Jun '26

11 Jun '26

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: a00ce157 by fendor at 2026-06-11T12:12:41+02:00 WIP: Introduce UnitIndex for global data - - - - - 9 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - libraries/ghc-boot/GHC/Unit/Database.hs - utils/haddock/haddock-api/src/Haddock.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do logger <- getLogger hsc_env <- getSession - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_eud old_unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -779,6 +779,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env , ue_eud = ue_eud old_unit_env + , ue_unit_index = ue_unit_index old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -837,6 +838,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_eps = ue_eps unit_env0 , ue_module_graph = ue_module_graph unit_env0 , ue_eud = ue_eud unit_env0 + , ue_unit_index = ue_unit_index unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -884,7 +886,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_eud unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -174,6 +174,8 @@ withBkpSession :: UnitId -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags + env <- getSession + unitIndex <- liftIO $ hscUnitIndex env let cid_fs = unitFS cid is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) @@ -193,8 +195,8 @@ withBkpSession cid insts deps session_type do_this = do | otherwise = sub_comp (key_base p) mk_temp_env hsc_env = - hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env - mk_temp_dflags unit_state dflags = dflags + hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env + mk_temp_dflags unit_index unit_state dflags = dflags { backend = case session_type of TcSession -> noBackend _ -> backend dflags @@ -241,7 +243,7 @@ withBkpSession cid insts deps session_type do_this = do , importPaths = [] -- Synthesize the flags , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnit unit_state + let uid = unwireUnit unit_index $ improveUnit unit_state $ renameHoleUnit unit_state (listToUFM insts) uid0 in ExposePackage @@ -352,9 +354,9 @@ buildUnit session cid insts lunit = do | otherwise = [Nothing] linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env) + unit_index <- liftIO $ hscUnitIndex hsc_env let obj_files = concatMap linkableFiles linkables - state = hsc_units hsc_env compat_fs = unitIdFS cid compat_pn = PackageName compat_fs @@ -380,7 +382,7 @@ buildUnit session cid insts lunit = do -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (toUnitId . unwireUnit state) + _ -> map (toUnitId . unwireUnit unit_index) $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ], @@ -452,7 +454,7 @@ addUnit u = do { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] } - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 eud (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env) -- update platform constants @@ -470,6 +472,7 @@ addUnit u = do , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env , ue_eud = ue_eud old_unit_env + , ue_unit_index = ue_unit_index old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -13,6 +13,8 @@ module GHC.Driver.Env , hsc_HUE , hsc_HUG , hsc_all_home_unit_ids + , hscUnitIndex + , hsc_unit_index , hscUpdateLoggerFlags , hscUpdateHUG , hscInsertHPT @@ -230,6 +232,12 @@ hscEUD = readExternalUnitDatabases . hscEUDC hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env) +hscUnitIndex :: HscEnv -> IO UnitIndex +hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env) + +hsc_unit_index :: HscEnv -> IORef UnitIndex +hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env) + -------------------------------------------------------------------------------- -- * Queries on Transitive Closure -------------------------------------------------------------------------------- ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do let hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscEUDC hsc_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -131,6 +131,7 @@ import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import Data.IORef -------------------------------------------------------------------------------- -- The hard queries @@ -177,6 +178,8 @@ data UnitEnv = UnitEnv , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) -- TODO: @fendor Docs + , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) + -- TODO: @fendor Docs } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -186,6 +189,7 @@ initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitE initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache eud <- initExternalUnitDatabaseCache + unit_index <- newIORef (initUnitIndex) return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug @@ -194,6 +198,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_platform = platform , ue_namever = namever , ue_eud = eud + , ue_unit_index = unit_index } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,6 +5,13 @@ module GHC.Unit.State ( module GHC.Unit.Info, + UnitIndex(..), + initUnitIndex, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + lookupUnitInfoMap, + -- * Reading the package config, and processing cmdline args UnitState(..), PreloadUnitClosure, @@ -28,7 +35,7 @@ module GHC.Unit.State ( lookupUnitId', unsafeLookupUnitId, isUnitTrusted, - isUnitIdTrusted, + isUnitIdTrusted, isUnitInfoTrusted, lookupPackageName, @@ -125,6 +132,8 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set import Control.Applicative import GHC.Unit.External.Database +import Data.IORef +import Data.Either (partitionEithers) -- --------------------------------------------------------------------------- -- The Unit state @@ -428,6 +437,40 @@ initUnitConfig dflags cached_dbs home_units = type ModuleNameProvidersMap = UniqMap ModuleName (UniqMap Module ModuleOrigin) +data UnitIndex = UnitIndex + { ui_wireMap :: WiringMap + , ui_unwireMap :: UnwiringMap + , ui_unitInfoMap :: UnitInfoMap + } + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index + } + +lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo +lookupUnitInfoMap unit_index unit_id = + lookupUniqMap (ui_unitInfoMap unit_index) unit_id + data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects @@ -452,11 +495,11 @@ data UnitState = UnitState { -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- | A mapping from database unit keys to wired in unit ids. - wireMap :: UniqMap UnitId UnitId, + -- -- | A mapping from database unit keys to wired in unit ids. + -- wireMap :: WiringMap, - -- | A mapping from wired in unit ids to unit keys from the database. - unwireMap :: UniqMap UnitId UnitId, + -- -- | A mapping from wired in unit ids to unit keys from the database. + -- unwireMap :: UnwiringMap, -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit @@ -502,8 +545,8 @@ emptyUnitState = UnitState { distrustedUnits = Set.empty, preloadClosure = emptyUniqSet, packageNameMap = emptyUFM, - wireMap = emptyUniqMap, - unwireMap = emptyUniqMap, + -- wireMap = emptyUniqMap, + -- unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], homeUnitDepends = Set.empty, @@ -657,20 +700,22 @@ isUnitInfoTrusted ue unit_info = -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) -initUnits logger dflags cached_dbs home_units = do +initUnits :: Logger -> DynFlags -> IORef UnitIndex -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags unit_index cached_dbs home_units = do let forceUnitInfoMap state = unitInfoMap state `seq` () unit_state <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger unit_index (initUnitConfig dflags cached_dbs home_units) putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - let home_unit = mkHomeUnit unit_state + wireMap <- ui_wireMap <$> readIORef unit_index + + let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) (homeUnitInstanceOf_ dflags) (homeUnitInstantiations_ dflags) @@ -695,16 +740,15 @@ initUnits logger dflags cached_dbs home_units = do return (unit_state,home_unit,mconstants) mkHomeUnit - :: UnitState + :: WiringMap -> UnitId -- ^ Home unit id -> Maybe UnitId -- ^ Home unit instance of -> [(ModuleName, Module)] -- ^ Home unit instantiations -> HomeUnit -mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ = +mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = let -- Some wired units can be used to instantiate the home unit. We need to -- replace their unit keys with their wired unit ids. - wmap = wireMap unit_state hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ in case (hu_instanceof, hu_instantiations) of (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing @@ -823,7 +867,8 @@ readUnitDatabase logger cfg conf_file = do pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- - return $ UnitDatabase conf_file' pkg_configs1 + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 where readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do @@ -902,6 +947,29 @@ mungeBytecodeLibFields pkg = ds -> ds } +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = do + importDirs <- evaluate $ unitImportDirs ui + includeDirs <- evaluate $ unitIncludeDirs ui + libraryDirs <- evaluate $ unitLibraryDirs ui + libraryBytecodeDirs <- evaluate $ unitLibraryBytecodeDirs ui + extDepFrameworkDirs <- evaluate $ unitExtDepFrameworkDirs ui + haddockInterfaces <- evaluate $ unitHaddockInterfaces ui + haddockHTMLs <- evaluate $ unitHaddockHTMLs ui + libraryDynDirs <- evaluate $ unitLibraryDynDirs ui + libraryDirsStatic <- evaluate $ unitLibraryDirsStatic ui + evaluate ui + { unitImportDirs = importDirs + , unitIncludeDirs = includeDirs + , unitLibraryDirs = libraryDirs + , unitLibraryDynDirs = libraryDynDirs + , unitLibraryDirsStatic = libraryDirsStatic + , unitLibraryBytecodeDirs = libraryBytecodeDirs + , unitExtDepFrameworkDirs = extDepFrameworkDirs + , unitHaddockInterfaces = haddockInterfaces + , unitHaddockHTMLs = haddockHTMLs + } + -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -1137,6 +1205,7 @@ pprTrustFlag flag = case flag of -- See Note [Wired-in units] in GHC.Unit.Types type WiringMap = UniqMap UnitId UnitId +type UnwiringMap = UniqMap UnitId UnitId findWiredInUnits :: Logger @@ -1144,9 +1213,7 @@ findWiredInUnits -> [UnitInfo] -- database -> VisibilityMap -- info on what units are visible -- for wired in selection - -> IO ([UnitInfo], -- unit database updated for wired in - WiringMap) -- map from unit id to wired identity - + -> IO WiringMap -- map from unit id to wired identity findWiredInUnits logger prec_map pkgs vis_map = do -- Now we must find our wired-in units, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described @@ -1209,27 +1276,41 @@ findWiredInUnits logger prec_map pkgs vis_map = do , not (unitIsIndefinite realUnitInfo) ] - updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs - where upd_pkg pkg - | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) - = pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - | otherwise - = pkg - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - - - return (updateWiredInDependencies pkgs, wiredInMap) + return wiredInMap + +updateWiredInUnits :: WiringMap -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_pkg pkg + | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) + = pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + | otherwise + = pkg + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap knownInfos (unitId pkg) of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_pkg pkg + in + Left updated_pkg -- Helper functions for rewiring Module and Unit. These -- rewrite Units of modules in wired-in packages to the form known to the @@ -1512,9 +1593,10 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger + -> IORef UnitIndex -> UnitConfig -> IO UnitState -mkUnitState logger cfg = do +mkUnitState logger unit_index cfg = do {- Plan. @@ -1605,7 +1687,7 @@ mkUnitState logger cfg = do -- Compute trust flags (these flags apply regardless of whether -- or not packages are visible or not) - (trusted, distrusted) <- mayThrowUnitErr + (!trusted, !distrusted) <- mayThrowUnitErr $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2)) (trustedUnits, distrustedUnits) (reverse (unitConfigFlagsTrusted cfg)) let pkgs1 = nonDetEltsUniqMap pkg_map2 @@ -1674,7 +1756,21 @@ mkUnitState logger cfg = do -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- - (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 + ui <- readIORef unit_index + (wired_map, pkgs2) <- do + wireMap <- if isWireMapEmpty ui + then do + wmap <- findWiredInUnits logger prec_map pkgs1 vis_map2 + modifyIORef' unit_index (setWireMap wmap) + pure wmap + else do + pure $ ui_wireMap ui + + let (new_pkgs, pkgs_set) = partitionEithers $ updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + + modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) + pure (wireMap, pkgs_set ++ new_pkgs) + let pkg_db = mkUnitInfoMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. @@ -1762,8 +1858,8 @@ mkUnitState logger cfg = do , moduleNameProvidersMap = mod_map , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map , packageNameMap = pkgname_map - , wireMap = wired_map - , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + -- , wireMap = wired_map + -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } @@ -1784,9 +1880,9 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. -unwireUnit :: UnitState -> Unit -> Unit +unwireUnit :: UnitIndex -> Unit -> Unit unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid) + maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) unwireUnit _ uid = uid -- ----------------------------------------------------------------------------- ===================================== ghc/GHCi/UI.hs ===================================== @@ -856,8 +856,9 @@ installInteractiveHomeUnits dflags = do setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv setupHomeUnitFor logger dflags all_home_units = do env <- GHC.getSession + let unit_index = hsc_unit_index env (unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (hscEUDC env) all_home_units + liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -746,11 +746,20 @@ mungeUnitInfoPaths top_dir pkgroot pkg = , unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg)) } where - munge_paths = map munge_path - munge_urls = map munge_url + munge_paths = strictMap munge_path + munge_urls = strictMap munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. -- Prefer 'decodeUtf' and gracious error handling. unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath unsafeDecodeUtf = OsPath.Internal.so + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x:xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -211,7 +211,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do logger' <- getLogger let logger = setLogFlags logger' (initLogFlags dflags) let parserOpts = Parser.initParserOpts dflags - !unit_state <- hsc_units <$> getSession + env <- getSession + let !unit_state = hsc_units env + !unit_index <- liftIO $ hscUnitIndex env -- If any --show-interface was used, show the given interfaces forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -238,7 +240,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual packages ifaces -- If we were not given any input files, error if documentation was -- requested @@ -251,7 +253,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages [] + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -307,6 +309,7 @@ renderStep :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -314,7 +317,7 @@ renderStep -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do +renderStep dflags parserOpts logger unit_index unit_state flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> docPathsHtml docPath @@ -330,7 +333,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs int (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + render dflags parserOpts logger unit_index unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap where -- get package name from unit-id packageName :: Unit -> String @@ -344,6 +347,7 @@ render :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -352,7 +356,7 @@ render -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () -render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do +render dflags parserOpts logger unit_index unit_state flags sinceQual qual ifaces packages extSrcMap = do let packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) $ optPackageName flags @@ -454,7 +458,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_index (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn' = hPutStrLn stderr . ("Warning: " ++) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a00ce157046e07ddea7d35426983d25… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a00ce157046e07ddea7d35426983d25… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/27370
by Zubin (＠wz1000) 11 Jun '26

11 Jun '26

Zubin pushed new branch wip/27370 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/27370 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/multi-caret] Shorten another comment, as suggested by @sheaf
by Simon Jakobi (＠sjakobi) 11 Jun '26

11 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: 99d0a9f9 by Simon Jakobi at 2026-06-11T09:33:10+00:00 Shorten another comment, as suggested by @sheaf - - - - - 1 changed file: - compiler/GHC/Tc/Errors/Types.hs Changes: ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -4131,12 +4131,7 @@ data TcRnMessage where TcRnBindingNameConflict :: !RdrName -- ^ The conflicting name -> !(NE.NonEmpty SrcSpan) -- ^ The locations of the duplicates, in ascending - -- source order. The last one is the primary span - -- of the message; 'diagnosticRelatedLocations' - -- returns the earlier ones, omitting any that - -- coincide with the primary span. See - -- Note [Choosing the primary and related spans] - -- in GHC.Types.Error. + -- source order. -> TcRnMessage {-| TcRnNonCanonicalDefinition is a warning indicating that an instance View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/99d0a9f942a09ee5847f678c29e9597… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/99d0a9f942a09ee5847f678c29e9597… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/fix-test] fix: make T27131 less flaky
by Rodrigo Mesquita (＠alt-romes) 11 Jun '26

11 Jun '26

Rodrigo Mesquita pushed to branch wip/romes/fix-test at Glasgow Haskell Compiler / GHC Commits: 7bb55140 by Rodrigo Mesquita at 2026-06-11T10:27:09+01:00 fix: make T27131 less flaky It seems that T27131 fails flakily in a race where we check the flag before the capability had the chance to process the mailbox which sets the flag. This seemingly should only happen if the capability ends up being the same for setting and checking the flag. - - - - - 2 changed files: - testsuite/tests/rts/T27131.hs - testsuite/tests/rts/T27131.stdout Changes: ===================================== testsuite/tests/rts/T27131.hs ===================================== @@ -30,16 +30,22 @@ foreign import ccall unsafe "has_local_stop_after_return" main :: IO () main = do setNumCapabilities 2 - checkFlag - "TSO_STOP_NEXT_BREAKPOINT" - rts_enableStopNextBreakpoint - rts_disableStopNextBreakpoint - c_hasLocalStopNextBreakpoint - checkFlag - "TSO_STOP_AFTER_RETURN" - rts_enableStopAfterReturn - rts_disableStopAfterReturn - c_hasLocalStopAfterReturn + -- Bind to capability 0 so it can't float between capabilities while the + -- target thread runs on capability 1. + doneVar <- newEmptyMVar + _ <- forkOn 0 $ do + checkFlag + "TSO_STOP_NEXT_BREAKPOINT" + rts_enableStopNextBreakpoint + rts_disableStopNextBreakpoint + c_hasLocalStopNextBreakpoint + checkFlag + "TSO_STOP_AFTER_RETURN" + rts_enableStopAfterReturn + rts_disableStopAfterReturn + c_hasLocalStopAfterReturn + putMVar doneVar () + takeMVar doneVar checkFlag :: String @@ -58,6 +64,7 @@ checkFlag label enable disable isMyThreadFlagSet = do ThreadId tid# <- forkOn 1 $ do replicateM_ 2 $ do replyVar <- takeMVar targetCheckVar + yield -- make sure we reprocess the mailbox isSet <- (/= 0) <$> isMyThreadFlagSet putMVar replyVar isSet ===================================== testsuite/tests/rts/T27131.stdout ===================================== @@ -1,6 +1,6 @@ -(0,False) +(0,True) TSO_STOP_NEXT_BREAKPOINT set: ok TSO_STOP_NEXT_BREAKPOINT unset: ok -(0,False) +(0,True) TSO_STOP_AFTER_RETURN set: ok TSO_STOP_AFTER_RETURN unset: ok View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bb5514009bf8e5df6962cefc4a03c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bb5514009bf8e5df6962cefc4a03c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/multi-caret] Shorten some comments as suggested by @sheaf.
by Simon Jakobi (＠sjakobi) 11 Jun '26

11 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: 9591c80d by Simon Jakobi at 2026-06-11T09:22:32+00:00 Shorten some comments as suggested by @sheaf. - - - - - 4 changed files: - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs Changes: ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -3764,13 +3764,8 @@ instance Diagnostic TcRnMessage where TcRnZonkerMessage{} -> [] -- | The prior occurrences of a duplicated entity, for use as the related --- locations of a \"duplicate\" diagnostic. Given all occurrences in ascending --- source order with the primary span last, return the earlier ones, omitting --- repeated spans and spans that coincide with the primary. Several --- occurrences can share a single span -- e.g. duplicate declarations brought --- into being by one TH splice -- and repeating the primary span among the --- related locations would draw its caret twice and emit it again in the JSON --- relatedSpans field. +-- locations of a \"duplicate\" diagnostic. +-- -- See Note [Choosing the primary and related spans] in GHC.Types.Error. priorOccurrences :: NE.NonEmpty SrcSpan -> [SrcSpan] priorOccurrences locs = ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -3981,13 +3981,7 @@ data TcRnMessage where TcRnDuplicateDecls :: !OccName -- ^ The name of the declarations -> !(NE.NonEmpty Name) -- ^ The individual declarations, in ascending source - -- order. The last one is the primary span of the - -- message; 'diagnosticRelatedLocations' returns the - -- earlier ones, omitting any that coincide with the - -- primary span (all occurrences can share one span, - -- e.g. when spliced by a single TH splice). See - -- Note [Choosing the primary and related spans] - -- in GHC.Types.Error. + -- order. -> TcRnMessage {-| TcRnPackageImportsDisabled is an error indicating that an import uses ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -258,30 +258,14 @@ which GHC's diagnostics are forwarded by HLS: an LSP diagnostic carries a single https://microsoft.github.io/language-server-protocol/specifications/lsp/3.1… -How the locations are rendered: - - * Related spans are additional to the primary span, not replacements for it. - The spans that receive a caret are @primary :| relatedLocations@ (see - 'GHC.Driver.Errors.printMessage' and 'defaultLogActionWithHandles'). - - * Locations are shown — both as carets and in the @At:@ list below — in - exactly the order the message author gives them: the primary span first, - then 'diagnosticRelatedLocations' as listed. The rendering layer neither - reorders nor deduplicates. - - * Not every location can be shown as a caret: carets are optional - (@-fno-diagnostics-show-caret@), and some spans have no source to display - anyway (e.g. GHCi input or TH-generated code). Locations that get no caret - are instead listed under an @At:@ heading ('pprAtLocations'; dropped when it - would name only the primary span, which the header already states). - Every location with a real source position thus appears either as a caret - or in the @At:@ list — only spans without one ('UnhelpfulSpan') are dropped - altogether — so messages need not spell the locations out in their prose. - Carets require 'IO' to read the source, so renderers other than - 'GHC.Utils.Logger.decorateDiagnostic' — in particular the pure - 'GHC.Utils.Error.pprLocMsgEnvelope', used e.g. when 'show'ing a - 'GHC.Types.SourceError.SourceError' and for deferred type errors — list - /all/ the locations under @At:@. +Locations are rendered exactly in the order they are provided. +Not every location can be shown as a caret: + - carets are optional (@-fno-diagnostics-show-caret@) + - some spans have no source to display anyway (e.g. GHCi input or TH-generated code) + - they require 'IO' to read the source code, so pure code (e.g. 'Show SourceError') + doesn't include them. + +Locations that get no caret are instead listed under an @At:@ heading. How a message author should pick and order the spans is the subject of Note [Choosing the primary and related spans]. @@ -903,11 +887,9 @@ pprAtLocations primary spans -- | When @show_caret@ is set, render carets for the given spans; otherwise -- render nothing. Either way, return the real spans that did /not/ get a caret, --- so the caller can report those locations textually. A span is missed when --- carets are disabled, or when its source is unavailable (an unhelpful span — --- dropped here — or unreadable source such as GHCi input or TH-generated code). --- The spans are kept in the order they were given in; see Note [The source span --- model for diagnostics]. +-- so the caller can report those locations textually. +-- +-- See Note [The source span model for diagnostics]. getCaretDiagnostics :: Bool -> MessageClass -> NonEmpty SrcSpan -> IO (SDoc, [RealSrcSpan]) getCaretDiagnostics show_caret msg_class spans | not show_caret = pure (empty, realSpans) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -479,11 +479,7 @@ decorateDiagnostic logflags msg_class srcSpan msg = addLocations _ -> [] -- The primary span is always caret'd, with the related spans drawn as - -- additional carets. Order is the message author's: the primary first, - -- then the related spans as given. 'getCaretDiagnostics' preserves that - -- order and does not deduplicate, so an author must not repeat the primary - -- among the related spans. - -- See Note [The source span model for diagnostics] in GHC.Types.Error. + -- additional carets. See Note [The source span model for diagnostics] in GHC.Types.Error. sourceSpans :: NonEmpty SrcSpan sourceSpans = srcSpan :| relatedSpans View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9591c80d912f90201549612ce9f27e5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9591c80d912f90201549612ce9f27e5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27176-clb
by Simon Jakobi (＠sjakobi2) 11 Jun '26

11 Jun '26

Simon Jakobi pushed new branch wip/sjakobi/T27176-clb at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27176-clb You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27368
by Simon Jakobi (＠sjakobi2) 11 Jun '26

11 Jun '26

Simon Jakobi pushed new branch wip/sjakobi/T27368 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27368 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/clabel-monomorphic] Deleted 1 commit: Only treat continuations of reachable calls as proc points
by Simon Jakobi (＠sjakobi2) 11 Jun '26

11 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/clabel-monomorphic at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: bf52c492 by Simon Jakobi at 2026-06-11T08:50:35+02:00 Only treat continuations of reachable calls as proc points callProcPoints used to fold over the whole block map, which can contain unreachable blocks: the control-flow optimiser and the common block eliminator both leave them behind, and they are only removed at the end of the Cmm pipeline (Note [unreachable blocks]). In particular, when CBE merges duplicated call blocks it leaves the losing copy in the block map, and the continuation of such a dead call can itself be unreachable. callProcPoints would still collect that continuation, attachContInfoTables would attach an info table to it, but stack layout (which only walks reachable blocks) produced no stack map for it, so setInfoTableStackMap panicked: ghc: panic! (the 'impossible' happened) setInfoTableStackMap This was triggered by compiling GHC.CmmToAsm.Dwarf.Types with -O2 after the previous commit reshaped the CLabel printers, but the bug is latent and independent of that change. Fix: make callProcPoints fold over revPostorder, i.e. reachable blocks only. Also correct the stale comment in elimCommonBlocks claiming that ContFlowOpt has already removed unreachable blocks, and extend Note [unreachable blocks] with the invariant and a warning that the Cmm pretty-printer hides unreachable blocks in dumps. Co-Authored-By: Claude Fable 5 <noreply(a)anthropic.com> - - - - - 3 changed files: - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/ProcPoint.hs Changes: ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -63,10 +63,16 @@ elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks g = replaceLabels env $ copyTicks env g where env = iterate mapEmpty blocks_with_key - -- The order of blocks doesn't matter here. While we could use - -- revPostorder which drops unreachable blocks this is done in - -- ContFlowOpt already which runs before this pass. So we use - -- toBlockList since it is faster. + -- The order of blocks doesn't matter here. Note that toBlockList + -- includes unreachable blocks (ContFlowOpt leaves them in the block + -- map, see Note [unreachable blocks] in GHC.Cmm.Pipeline), so we may + -- hash and merge dead blocks, and a live block may even be + -- substituted by an unreachable duplicate (resurrecting it). That is + -- semantically harmless since the blocks are identical, but it means + -- this pass both consumes and produces unreachable blocks; passes + -- between this one and the final removeUnreachableBlocksProc must + -- not let blocks that are unreachable here influence the reachable + -- part of the graph (see e.g. callProcPoints in GHC.Cmm.ProcPoint). groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -352,10 +352,22 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. {- Note [unreachable blocks] ~~~~~~~~~~~~~~~~~~~~~~~~~ -The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. These aren't necessarily a problem, but -removing them is good because it might save time in the native code -generator later. +The control-flow optimiser and the common block eliminator sometimes +leave unreachable blocks behind containing junk code; they are only +removed here, at the end of the pipeline. Removing them earlier would +cost extra reachability passes, but deferring the removal means every +pass in between runs on a block map that may contain unreachable +blocks, and must take care that they don't influence the reachable +part of the graph. In particular, the continuation of a call in an +unreachable block may itself be unreachable, so it must not be treated +as a proc point: stack layout only lays out reachable blocks, and an +info table attached (by attachContInfoTables) to a continuation +without a stack map makes setInfoTableStackMap panic. See +callProcPoints in GHC.Cmm.ProcPoint. + +Beware also that the Cmm pretty-printer omits unreachable blocks, so +they do not show up in -ddump-cmm-* output; a dump can therefore look +consistent while the underlying block map is not. -} ===================================== compiler/GHC/Cmm/ProcPoint.hs ===================================== @@ -173,8 +173,16 @@ procPointLattice = DataflowLattice unreached add_to -- introduced because they're reachable from multiple proc points. -- -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds]. +-- +-- We must consider only *reachable* blocks: the common block eliminator +-- leaves duplicated (hence unreachable) call blocks in the block map +-- (see Note [unreachable blocks] in GHC.Cmm.Pipeline), and the +-- continuation of such a dead call may itself be unreachable. Stack +-- layout only lays out reachable blocks, so a continuation collected +-- from a dead call would get an info table (attachContInfoTables) but +-- no stack map, making setInfoTableStackMap panic. callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g +callProcPoints g = foldl' add (setSingleton (g_entry g)) (revPostorder g) where add :: LabelSet -> CmmBlock -> LabelSet add set b = case lastNode b of CmmCall {cml_cont = Just k} -> setInsert k set View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf52c49204953d0ffd2b1c5a74003f4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf52c49204953d0ffd2b1c5a74003f4… You're receiving this email because of your account on gitlab.haskell.org.

1 0