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

Commits:

11 changed files:

Changes:

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