Hannes Siebenhandl pushed to branch wip/fendor/27836 at Glasgow Haskell Compiler / GHC Commits: 671c3b88 by Hannes Siebenhandl at 2026-10-02T15:49:57+02:00 Fix #27836, normalise unit database path in ExternalUnitDatabases Add a regression test, proofing that all variations: - local-unit-db/my-test.conf - ./local-unit-db/my-test.conf - ./local-unit-db/my-test.conf/ are parsed only once. - - - - - 12 changed files: - changelog.d/unit-index - compiler/GHC/Data/OsPath.hs - compiler/GHC/Unit/External/Database.hs - + testsuite/tests/driver/T27836/A.hs - + testsuite/tests/driver/T27836/B.hs - + testsuite/tests/driver/T27836/C.hs - + testsuite/tests/driver/T27836/Makefile - + testsuite/tests/driver/T27836/T27836.stdout - + testsuite/tests/driver/T27836/all.T - + testsuite/tests/driver/T27836/unitA - + testsuite/tests/driver/T27836/unitB - + testsuite/tests/driver/T27836/unitC Changes: ===================================== changelog.d/unit-index ===================================== @@ -1,7 +1,7 @@ section: compiler synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units -issues: #27500 #26423 #27748 -mrs: !16115 !16598 +issues: #27500 #26423 #27748 #27836 +mrs: !16115 !16598 !16729 description: { The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -13,6 +13,7 @@ module GHC.Data.OsPath , (<.>) , splitSearchPath , isRelative + , normalise , dropTrailingPathSeparator , takeDirectory , isSuffixOf ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -53,9 +53,17 @@ import System.FilePath as FilePath -- ExternalUnitDatabases -- ---------------------------------------------------------------------------- +-- | A normalised 'OsPath' that we use as the key to cache 'UnitDatabase's. +-- +-- Removes trailing path separators and unit database paths starting with @./@. +newtype NormalisedUnitDbLoc = NormalisedUnitDbLoc OsPath + deriving (Eq, Ord) + -- | Caches unit databases in-memory. data ExternalUnitDatabases unit = ExternalUnitDatabases - { eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit)) + { eud_cachedDatabases :: !(Map NormalisedUnitDbLoc (UnitDatabase unit)) + -- ^ The 'Map' is keyed by a normalised 'OsPath', ensuring that 'lookupExternalUnitDatabases' + -- will never get confused by a stray @./@ or trailing @/@. } emptyExternalUnitDatabases :: ExternalUnitDatabases unit @@ -67,18 +75,20 @@ emptyExternalUnitDatabases = insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit insertExternalUnitDatabases unit_db eud = ExternalUnitDatabases - { eud_cachedDatabases = Map.insert (unitDatabasePath unit_db) unit_db (eud_cachedDatabases eud) + { eud_cachedDatabases = + Map.insert (normalisedUnitDatabaseKey unit_db) unit_db (eud_cachedDatabases eud) } deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit deleteExternalUnitDatabases unit_db_path eud = ExternalUnitDatabases - { eud_cachedDatabases = Map.delete unit_db_path (eud_cachedDatabases eud) + { eud_cachedDatabases = + Map.delete (normalisedUnitDatabaseKeyOsPath unit_db_path) (eud_cachedDatabases eud) } lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit) lookupExternalUnitDatabases key eud = - Map.lookup key (eud_cachedDatabases eud) + Map.lookup (normalisedUnitDatabaseKeyOsPath key) (eud_cachedDatabases eud) -- ---------------------------------------------------------------------------- -- UnitDatabase @@ -87,12 +97,38 @@ lookupExternalUnitDatabases key eud = -- | Unit database entry. data UnitDatabase unit = UnitDatabase { unitDatabasePath :: OsPath + -- ^ On-disk location of the unit database. + -- , unitDatabaseUnits :: [GenUnitInfo unit] + -- ^ Units read from the database located at 'unitDatabasePath'. + -- + -- These units have the @$pkgroot@ variable already resolved. } instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp +normalisedUnitDatabaseKey :: UnitDatabase unit -> NormalisedUnitDbLoc +normalisedUnitDatabaseKey unit_db = normalisedUnitDatabaseKeyOsPath $ unitDatabasePath unit_db + +-- | Normalise the unit database location and drop trailing path separators. +-- +-- This ensures that two databases that point to the same location can be cached. +-- +-- We need to remove trailing slash from the 'OsPath' before calculating @$pkgroot@ (Fix #16360) +normalisedUnitDatabaseKeyOsPath :: OsPath -> NormalisedUnitDbLoc +normalisedUnitDatabaseKeyOsPath db_path = + NormalisedUnitDbLoc $ OsPath.dropTrailingPathSeparator $ OsPath.normalise db_path + +-- | Get the root location of a unit database. +-- Used to replace @$pkgroot@ variables in the 'GenericUnitInfo'. +unitDatabaseRoot :: OsPath -> OsPath +unitDatabaseRoot p = + let + NormalisedUnitDbLoc np = normalisedUnitDatabaseKeyOsPath p + in + OsPath.takeDirectory np + -- ---------------------------------------------------------------------------- -- -- Merging databases @@ -258,14 +294,12 @@ readUnitDatabase logger cfg conf_file = do "can't find a package database at " ++ show conf_file let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' + pkgroot = unitDatabaseRoot conf_file pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- - return $ UnitDatabase conf_file' pkg_configs1 + return $ UnitDatabase conf_file pkg_configs1 where readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do ===================================== testsuite/tests/driver/T27836/A.hs ===================================== @@ -0,0 +1,4 @@ +module A where + +a :: Int +a = 1 ===================================== testsuite/tests/driver/T27836/B.hs ===================================== @@ -0,0 +1,4 @@ +module B where + +b :: Int +b = 1 ===================================== testsuite/tests/driver/T27836/C.hs ===================================== @@ -0,0 +1,4 @@ +module C where + +b :: Int +b = 1 ===================================== testsuite/tests/driver/T27836/Makefile ===================================== @@ -0,0 +1,21 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T27836: + mkdir local-unit-db/ + cd local-unit-db/ && '$(GHC_PKG)' init my-test.conf + # All these unit database paths should resolve to the same location + # thus after the first time parsing the unit database, we shouldn't parse it again. + '$(TEST_HC)' $(TEST_HC_OPTS) --make \ + -unit @unitA -unit @unitB -unit @unitC \ + -v2 -fforce-recomp 2>&1 \ + | grep 'Using binary package database:' + + echo "" + echo "" + echo "All -package-db variations:" + echo "- local-unit-db/my-test.conf" + echo "- ./local-unit-db/my-test.conf" + echo "- ./local-unit-db/my-test.conf/" + echo "Must be parsed only once." ===================================== testsuite/tests/driver/T27836/T27836.stdout ===================================== @@ -0,0 +1,8 @@ +Using binary package database: local-unit-db/my-test.conf/package.cache + + +All -package-db variations: +- local-unit-db/my-test.conf +- ./local-unit-db/my-test.conf +- ./local-unit-db/my-test.conf/ +Must be parsed only once. ===================================== testsuite/tests/driver/T27836/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27836', + [ extra_files(['A.hs', 'B.hs', 'C.hs', 'unitA', 'unitB', 'unitC']), normalise_slashes + ], + makefile_test, ['T27836']) ===================================== testsuite/tests/driver/T27836/unitA ===================================== @@ -0,0 +1 @@ +-hide-all-packages -no-user-package-db -package-db local-unit-db/my-test.conf -package base -this-unit-id a-0.0.0 A ===================================== testsuite/tests/driver/T27836/unitB ===================================== @@ -0,0 +1 @@ +-hide-all-packages -no-user-package-db -package-db ./local-unit-db/my-test.conf -package base -this-unit-id b-0.0.0 B ===================================== testsuite/tests/driver/T27836/unitC ===================================== @@ -0,0 +1 @@ +-hide-all-packages -no-user-package-db -package-db ./local-unit-db/my-test.conf/ -package base -this-unit-id c-0.0.0 C View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/671c3b88e43df1fe1c6ae21809f627a4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/671c3b88e43df1fe1c6ae21809f627a4... 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