diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-01-15 17:48:30 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-01-31 02:46:15 -0500 |
commit | 29c701c154cafa4844cf3c1bd4a93cacfa6b1ee1 (patch) | |
tree | 88a060f43c73306463510b53607c1fd9460bd84b /compiler/backpack | |
parent | bf38a20eefcaaaac404a1818c3eff8273dc67dd9 (diff) | |
download | haskell-29c701c154cafa4844cf3c1bd4a93cacfa6b1ee1.tar.gz |
Refactor package related code
The package terminology is a bit of a mess. Cabal packages contain
components. Instances of these components when built with some
flags/options/dependencies are called units. Units are registered into
package databases and their metadata are called PackageConfig.
GHC only knows about package databases containing units. It is a sad
mismatch not fixed by this patch (we would have to rename parameters
such as `package-id <unit-id>` which would affect users).
This patch however fixes the following internal names:
- Renames PackageConfig into UnitInfo.
- Rename systemPackageConfig into globalPackageDatabase[Path]
- Rename PkgConfXX into PkgDbXX
- Rename pkgIdMap into unitIdMap
- Rename ModuleToPkgDbAll into ModuleNameProvidersMap
- Rename lookupPackage into lookupUnit
- Add comments on DynFlags package related fields
It also introduces a new `PackageDatabase` datatype instead of
explicitly passing the following tuple: `(FilePath,[PackageConfig])`.
The `pkgDatabase` field in `DynFlags` now contains the unit info for
each unit of each package database exactly as they have been read from
disk. Previously the command-line flag `-distrust-all-packages` would
modify these unit info. Now this flag only affects the "dynamic"
consolidated package state found in `pkgState` field. It makes sense
because `initPackages` could be called first with this
`distrust-all-packages` flag set and then again (using ghc-api) without
and it should work (package databases are not read again from disk when
`initPackages` is called the second time).
Bump haddock submodule
Diffstat (limited to 'compiler/backpack')
-rw-r--r-- | compiler/backpack/BkpSyn.hs | 2 | ||||
-rw-r--r-- | compiler/backpack/DriverBkp.hs | 29 |
2 files changed, 15 insertions, 16 deletions
diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs index ce14018883..fcc0160899 100644 --- a/compiler/backpack/BkpSyn.hs +++ b/compiler/backpack/BkpSyn.hs @@ -23,7 +23,7 @@ import GHC.Hs import SrcLoc import Outputable import Module -import PackageConfig +import UnitInfo {- ************************************************************************ diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs index 0afef71bb7..e8fdba5bd3 100644 --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -190,7 +190,7 @@ withBkpSession cid insts deps session_type do_this = do importPaths = [], -- Synthesized the flags packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) + let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) in ExposePackage (showSDoc dflags (text "-unit-id" <+> ppr uid <+> ppr rn)) @@ -271,7 +271,7 @@ buildUnit session cid insts lunit = do dflags <- getDynFlags -- IMPROVE IT - let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0 + let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0 mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc @@ -375,20 +375,19 @@ compileExe lunit = do ok <- load' LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -addPackage :: GhcMonad m => PackageConfig -> m () +-- | Register a new virtual package database containing a single unit +addPackage :: GhcMonad m => UnitInfo -> m () addPackage pkg = do - dflags0 <- GHC.getSessionDynFlags - case pkgDatabase dflags0 of + dflags <- GHC.getSessionDynFlags + case pkgDatabase dflags of Nothing -> panic "addPackage: called too early" - Just pkgs -> do let dflags = dflags0 { pkgDatabase = - Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) } - _ <- GHC.setSessionDynFlags dflags - -- By this time, the global ref has probably already - -- been forced, in which case doing this isn't actually - -- going to do you any good. - -- dflags <- GHC.getSessionDynFlags - -- liftIO $ setUnsafeGlobalDynFlags dflags - return () + Just dbs -> do + let newdb = PackageDatabase + { packageDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")" + , packageDatabaseUnits = [pkg] + } + _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) }) + return () -- Precondition: UnitId is NOT InstalledUnitId compileInclude :: Int -> (Int, UnitId) -> BkpM () @@ -397,7 +396,7 @@ compileInclude n (i, uid) = do let dflags = hsc_dflags hsc_env msgInclude (i, n) uid -- Check if we've compiled it already - case lookupPackage dflags uid of + case lookupUnit dflags uid of Nothing -> do case splitUnitIdInsts uid of (_, Just indef) -> |