Hannes Siebenhandl pushed to branch wip/fendor/27836 at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • changelog.d/unit-index
    1 1 
     section: compiler
    2 2 
     synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units
    3 
    -issues: #27500 #26423 #27748 #27834
    4 
    -mrs: !16115 !16598 !16743
    3 
    +issues: #27500 #26423 #27748 #27834 #27836
    4 
    +mrs: !16115 !16598 !16743 !16729
    5 5
    6 6 
     description: {
    7 7 
         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
    13 13 
       , (<.>)
    14 14 
       , splitSearchPath
    15 15 
       , isRelative
    16 
    +  , normalise
    16 17 
       , dropTrailingPathSeparator
    17 18 
       , takeDirectory
    18 19 
       , isSuffixOf

  • compiler/GHC/Unit/External/Database.hs
    ... ... @@ -53,9 +53,17 @@ import System.FilePath as FilePath
    53 53 
     -- ExternalUnitDatabases
    54 54 
     -- ----------------------------------------------------------------------------
    55 55
    56 
    +-- | A normalised 'OsPath' that we use as the key to cache 'UnitDatabase's.
    57 
    +--
    58 
    +-- Removes trailing path separators and unit database paths starting with @./@.
    59 
    +newtype NormalisedUnitDbLoc = NormalisedUnitDbLoc OsPath
    60 
    +  deriving (Eq, Ord)
    61 
    +
    56 62 
     -- | Caches unit databases in-memory.
    57 63 
     data ExternalUnitDatabases unit = ExternalUnitDatabases
    58 
    -  { eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit))
    64 
    +  { eud_cachedDatabases :: !(Map NormalisedUnitDbLoc (UnitDatabase unit))
    65 
    +  -- ^ The 'Map' is keyed by a normalised 'OsPath', ensuring that 'lookupExternalUnitDatabases'
    66 
    +  -- will never get confused by a stray @./@ or trailing @/@.
    59 67 
       }
    60 68
    61 69 
     emptyExternalUnitDatabases :: ExternalUnitDatabases unit
    ... ... @@ -67,18 +75,20 @@ emptyExternalUnitDatabases =
    67 75 
     insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
    68 76 
     insertExternalUnitDatabases unit_db eud =
    69 77 
       ExternalUnitDatabases
    70 
    -    { eud_cachedDatabases = Map.insert (unitDatabasePath unit_db) unit_db (eud_cachedDatabases eud)
    78 
    +    { eud_cachedDatabases =
    79 
    +        Map.insert (normalisedUnitDatabaseKey unit_db) unit_db (eud_cachedDatabases eud)
    71 80 
         }
    72 81
    73 82 
     deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
    74 83 
     deleteExternalUnitDatabases unit_db_path eud =
    75 84 
       ExternalUnitDatabases
    76 
    -    { eud_cachedDatabases = Map.delete unit_db_path (eud_cachedDatabases eud)
    85 
    +    { eud_cachedDatabases =
    86 
    +        Map.delete (normalisedUnitDatabaseKeyOsPath unit_db_path) (eud_cachedDatabases eud)
    77 87 
         }
    78 88
    79 89 
     lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit)
    80 90 
     lookupExternalUnitDatabases key eud =
    81 
    -  Map.lookup key (eud_cachedDatabases eud)
    91 
    +  Map.lookup (normalisedUnitDatabaseKeyOsPath key) (eud_cachedDatabases eud)
    82 92
    83 93 
     -- ----------------------------------------------------------------------------
    84 94 
     -- UnitDatabase
    ... ... @@ -87,12 +97,38 @@ lookupExternalUnitDatabases key eud =
    87 97 
     -- | Unit database entry.
    88 98 
     data UnitDatabase unit = UnitDatabase
    89 99 
       { unitDatabasePath :: OsPath
    100 
    +  -- ^ On-disk location of the unit database.
    101 
    +  --
    90 102 
       , unitDatabaseUnits :: [GenUnitInfo unit]
    103 
    +  -- ^ Units read from the database located at 'unitDatabasePath'.
    104 
    +  --
    105 
    +  -- These units have the @$pkgroot@ variable already resolved.
    91 106 
       }
    92 107
    93 108 
     instance (Outputable u) => Outputable (UnitDatabase u) where
    94 109 
       ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp
    95 110
    111 
    +normalisedUnitDatabaseKey :: UnitDatabase unit -> NormalisedUnitDbLoc
    112 
    +normalisedUnitDatabaseKey unit_db = normalisedUnitDatabaseKeyOsPath $ unitDatabasePath unit_db
    113 
    +
    114 
    +-- | Normalise the unit database location and drop trailing path separators.
    115 
    +--
    116 
    +-- This ensures that two databases that point to the same location can be cached.
    117 
    +--
    118 
    +-- We need to remove trailing slash from the 'OsPath' before calculating @$pkgroot@ (Fix #16360)
    119 
    +normalisedUnitDatabaseKeyOsPath :: OsPath -> NormalisedUnitDbLoc
    120 
    +normalisedUnitDatabaseKeyOsPath db_path =
    121 
    +  NormalisedUnitDbLoc $ OsPath.dropTrailingPathSeparator $ OsPath.normalise db_path
    122 
    +
    123 
    +-- | Get the root location of a unit database.
    124 
    +-- Used to replace @$pkgroot@ variables in the 'GenericUnitInfo'.
    125 
    +unitDatabaseRoot :: OsPath -> OsPath
    126 
    +unitDatabaseRoot p =
    127 
    +  let
    128 
    +    NormalisedUnitDbLoc np = normalisedUnitDatabaseKeyOsPath p
    129 
    +  in
    130 
    +    OsPath.takeDirectory np
    131 
    +
    96 132 
     -- ----------------------------------------------------------------------------
    97 133 
     --
    98 134 
     -- Merging databases
    ... ... @@ -258,14 +294,12 @@ readUnitDatabase logger cfg conf_file = do
    258 294 
                           "can't find a package database at " ++ show conf_file
    259 295
    260 296 
       let
    261 
    -      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
    262 
    -      conf_file' = OsPath.dropTrailingPathSeparator conf_file
    263 297 
           top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg)
    264 
    -      pkgroot = OsPath.takeDirectory conf_file'
    298 
    +      pkgroot = unitDatabaseRoot conf_file
    265 299 
           pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
    266 300 
                              proto_pkg_configs
    267 301 
       --
    268 
    -  return $ UnitDatabase conf_file' pkg_configs1
    302 
    +  return $ UnitDatabase conf_file pkg_configs1
    269 303 
       where
    270 304 
         readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
    271 305 
         readDirStyleUnitInfo conf_dir = do

  • testsuite/tests/driver/T27836/A.hs
    1 
    +module A where
    2 
    +
    3 
    +a :: Int
    4 
    +a = 1

  • testsuite/tests/driver/T27836/B.hs
    1 
    +module B where
    2 
    +
    3 
    +b :: Int
    4 
    +b = 1

  • testsuite/tests/driver/T27836/C.hs
    1 
    +module C where
    2 
    +
    3 
    +b :: Int
    4 
    +b = 1

  • testsuite/tests/driver/T27836/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk
    4 
    +
    5 
    +T27836:
    6 
    +	mkdir local-unit-db/
    7 
    +	cd local-unit-db/ && '$(GHC_PKG)' init my-test.conf
    8 
    +	# All these unit database paths should resolve to the same location
    9 
    +	# thus after the first time parsing the unit database, we shouldn't parse it again.
    10 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) --make \
    11 
    +			-unit @unitA -unit @unitB -unit @unitC \
    12 
    +			-v2 -fforce-recomp 2>&1 \
    13 
    +		| grep 'Using binary package database:'
    14 
    +
    15 
    +	echo ""
    16 
    +	echo ""
    17 
    +	echo "All -package-db variations:"
    18 
    +	echo "- local-unit-db/my-test.conf"
    19 
    +	echo "- ./local-unit-db/my-test.conf"
    20 
    +	echo "- ./local-unit-db/my-test.conf/"
    21 
    +	echo "Must be parsed only once."

  • testsuite/tests/driver/T27836/T27836.stdout
    1 
    +Using binary package database: local-unit-db/my-test.conf/package.cache
    2 
    +
    3 
    +
    4 
    +All -package-db variations:
    5 
    +- local-unit-db/my-test.conf
    6 
    +- ./local-unit-db/my-test.conf
    7 
    +- ./local-unit-db/my-test.conf/
    8 
    +Must be parsed only once.

  • testsuite/tests/driver/T27836/all.T
    1 
    +test('T27836',
    2 
    +    [ extra_files(['A.hs', 'B.hs', 'C.hs', 'unitA', 'unitB', 'unitC']), normalise_slashes
    3 
    +    ],
    4 
    +    makefile_test, ['T27836'])

  • testsuite/tests/driver/T27836/unitA
    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
    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
    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.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/c6160c09956da0a472af5f531933618736307d68 at 1791196553