[Git][ghc/ghc][wip/romes/no-this-unit-id-aggressive] Aggressive deletion
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Mar 6 17:01:37 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/no-this-unit-id-aggressive at Glasgow Haskell Compiler / GHC
Commits:
22036aa2 by romes at 2023-03-06T17:01:23+00:00
Aggressive deletion
- - - - -
4 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/Types.hs
- + del-this-unit-id.sh
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -235,8 +235,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
- $ improveUnit unit_state
+ let uid = improveUnit unit_state
$ renameHoleUnit unit_state (listToUFM insts) uid0
in ExposePackage
(showSDoc dflags
@@ -372,7 +371,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
$ deps ++ [ moduleUnit mod
| (_, mod) <- insts
, not (isHoleModule mod) ],
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -69,7 +69,6 @@ module GHC.Unit.State (
pprWithUnitState,
-- * Utils
- unwireUnit,
implicitPackageDeps)
where
@@ -431,13 +430,6 @@ data UnitState = UnitState {
-- And also to resolve package qualifiers with the PackageImports extension.
packageNameMap :: UniqFM PackageName UnitId,
- -- TODO: Remove these two completely?
- -- | A mapping from database unit keys to wired in unit ids.
- wireMap :: Map UnitId UnitId,
-
- -- | A mapping from wired in unit ids to unit keys from the database.
- unwireMap :: Map UnitId UnitId,
-
-- | The units we're going to link in eagerly. This list
-- should be in reverse dependency order; that is, a unit
-- is always mentioned before the units it depends on.
@@ -480,8 +472,6 @@ emptyUnitState = UnitState {
unitInfoMap = Map.empty,
preloadClosure = emptyUniqSet,
packageNameMap = emptyUFM,
- wireMap = Map.empty,
- unwireMap = Map.empty,
preloadUnits = [],
explicitUnits = [],
homeUnitDepends = [],
@@ -673,13 +663,8 @@ mkHomeUnit
-> Maybe UnitId -- ^ Home unit instance of
-> [(ModuleName, Module)] -- ^ Home unit instantiations
-> HomeUnit
-mkHomeUnit unit_state 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
+mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations =
+ case (hu_instanceof, hu_instantiations) of
(Nothing,[]) -> DefiniteHomeUnit hu_id Nothing
(Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
(Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")
@@ -1082,7 +1067,7 @@ pprTrustFlag flag = case flag of
--
-- See Note [Wired-in units] in GHC.Unit.Types
-type WiringMap = Map UnitId UnitId
+type WiringMap = Map WiredInPackageName UnitId
findWiredInUnits
:: Logger
@@ -1119,8 +1104,8 @@ findWiredInUnits logger prec_map pkgs vis_map = do
-- this works even when there is no exposed wired in package
-- available.
--
- findWiredInUnitByName :: [UnitInfo] -> FastString -> IO (Maybe (FastString, UnitInfo))
- findWiredInUnitByName pkgs wired_pkg_name = firstJustsM [try all_exposed_ps, try all_ps, notfound] -- ROMES:TODO: In fact, here we ?
+ findWiredInUnitByName :: [UnitInfo] -> WiredInPackageName -> IO (Maybe (FastString, UnitInfo))
+ findWiredInUnitByName pkgs (WiredInPackageName wired_pkg_name) = firstJustsM [try all_exposed_ps, try all_ps, notfound] -- ROMES:TODO: In fact, here we ?
where
all_ps = [ p | p <- pkgs, p `matches` wired_pkg_name ]
all_exposed_ps = [ p | p <- all_ps, Map.member (mkUnit p) vis_map ]
@@ -1150,65 +1135,45 @@ findWiredInUnits logger prec_map pkgs vis_map = do
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
- wiredInMap :: Map UnitId UnitId
+ wiredInMap :: Map WiredInPackageName UnitId
wiredInMap = Map.fromList
- [ (unitId realUnitInfo, UnitId wiredInUnitId)
- | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
+ [ (WiredInPackageName wiredInUnitName, unitId realUnitInfo)
+ | (wiredInUnitName, realUnitInfo) <- wired_in_pkgs
, not (unitIsIndefinite realUnitInfo)
]
- updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
- where upd_pkg pkg
- | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap
- = 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)
-
--- Helper functions for rewiring Module and Unit. These
--- rewrite Units of modules in wired-in packages to the form known to the
--- compiler, as described in Note [Wired-in units] in GHC.Unit.Types.
---
--- For instance, base-4.9.0.0 will be rewritten to just base, to match
--- what appears in GHC.Builtin.Names.
-
-upd_wired_in_mod :: WiringMap -> Module -> Module
-upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
-
-upd_wired_in_uid :: WiringMap -> Unit -> Unit
-upd_wired_in_uid wiredInMap u = case u of
- HoleUnit -> HoleUnit
- RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))
- VirtUnit indef_uid ->
- VirtUnit $ mkInstantiatedUnit
- (instUnitInstanceOf indef_uid)
- (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid))
-
-upd_wired_in :: WiringMap -> UnitId -> UnitId
-upd_wired_in wiredInMap key
- | Just key' <- Map.lookup key wiredInMap = key'
- | otherwise = key
-
-updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
-updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
- where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of
- Nothing -> vm
- Just r -> Map.insert (RealUnit (Definite to)) r
- (Map.delete (RealUnit (Definite from)) vm)
+ --ROMES:TODO
+ --updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
+ -- where upd_pkg pkg
+ -- | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap
+ -- = 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)
+ -- }
+
+
+ -- ROMES:TODO return (updateWiredInDependencies pkgs, wiredInMap)
+ return (pkgs, wiredInMap)
+
+-- We no longer have visibility issues since we remove the indirection?
+-- This function was updating the wired-in names in the visibility map to the actual wired-in names, no longer needed
+-- updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
+-- updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
+-- where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of
+-- Nothing -> vm
+-- Just r -> Map.insert (RealUnit (Definite to)) r
+-- (Map.delete (RealUnit (Definite from)) vm)
-- ----------------------------------------------------------------------------
@@ -1601,7 +1566,7 @@ mkUnitState logger cfg = do
-- -hide-package). This needs to know about the unusable packages, since if a
-- user tries to enable an unusable package, we should let them know.
--
- vis_map2 <- mayThrowUnitErr
+ vis_map <- mayThrowUnitErr
$ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
(unitConfigHideAll cfg) pkgs1)
vis_map1 other_flags
@@ -1611,14 +1576,11 @@ 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
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map
let pkg_db = mkUnitInfoMap pkgs2
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ hide_plugin_pkgs = unitConfigHideAllPlugins cfg
plugin_vis_map <-
case unitConfigFlagsPlugins cfg of
-- common case; try to share the old vis_map
@@ -1629,22 +1591,19 @@ mkUnitState logger cfg = do
-- Use the vis_map PRIOR to wired in,
-- because otherwise applyPackageFlag
-- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
+ | otherwise = vis_map
+ plugin_vis_map
<- mayThrowUnitErr
$ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
hide_plugin_pkgs pkgs1)
plugin_vis_map1
(reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
-- TODO: If a wired in package had a compiler plugin,
-- and you tried to pick different wired in packages
-- with the plugin flags and the normal flags... what
-- would happen? I don't know! But this doesn't seem
-- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
+ return plugin_vis_map
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
@@ -1696,13 +1655,11 @@ mkUnitState logger cfg = do
, moduleNameProvidersMap = mod_map
, pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
, packageNameMap = pkgname_map
- , wireMap = wired_map
- , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]
, requirementContext = req_ctx
, allowVirtualUnits = unitConfigAllowVirtual cfg
}
- writeIORef workingThisOut (unwireMap state)
+ writeIORef workingThisOut wired_map
return (state, raw_dbs)
selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
@@ -1717,14 +1674,6 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags
-- MP: This does not yet support thinning/renaming
go cur _ = cur
-
--- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
--- that it was recorded as in the package database.
-unwireUnit :: UnitState -> Unit -> Unit
-unwireUnit state uid@(RealUnit (Definite def_uid)) =
- maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state))
-unwireUnit _ uid = uid
-
-- -----------------------------------------------------------------------------
-- | Makes the mapping from ModuleName to package info
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Unit & Module types
@@ -37,6 +38,7 @@ module GHC.Unit.Types
, DefUnitId
, Instantiations
, GenInstantiations
+ , WiredInPackageName (..)
, mkInstantiatedUnit
, mkInstantiatedUnitHash
, mkVirtUnit
@@ -120,8 +122,8 @@ import {-# SOURCE #-} Language.Haskell.Syntax.ImpExp (IsBootInterface(..))
-- Ref for an "unwireMap" which maps wired-in ids to actual units, created by
-- identifying wired-in packages in the list of package-id flags
-workingThisOut :: IORef (Map UnitId UnitId)
-workingThisOut = unsafePerformIO (newIORef (Map.singleton (UnitId $ fsLit "ouch-version") (UnitId $ fsLit "ouch")))
+workingThisOut :: IORef (Map WiredInPackageName UnitId)
+workingThisOut = unsafePerformIO (newIORef (Map.singleton (WiredInPackageName $ fsLit "ouch-version") (UnitId $ fsLit "ouch")))
{-# NOINLINE workingThisOut #-}
---------------------------------------------------------------------
@@ -557,6 +559,11 @@ unitIdString = unpackFS . unitIdFS
stringToUnitId :: String -> UnitId
stringToUnitId = UnitId . mkFastString
+newtype WiredInPackageName = WiredInPackageName
+ { wiredInPackageNameFS :: FastString }
+ deriving (Data)
+ deriving (Binary, Eq, Ord, Uniquable, Outputable) via UnitId
+
---------------------------------------------------------------------
-- UTILS
---------------------------------------------------------------------
@@ -601,7 +608,7 @@ Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here.
-}
bignumUnitName, primUnitName, baseUnitName, rtsUnitName,
- thUnitName, mainUnitName, thisGhcUnitName, interactiveUnitName :: FastString
+ thUnitName, mainUnitName, thisGhcUnitName, interactiveUnitName :: WiredInPackageName
bignumUnitId, primUnitId, baseUnitId, rtsUnitId,
thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
@@ -609,20 +616,20 @@ bignumUnitId, primUnitId, baseUnitId, rtsUnitId,
bignumUnit, primUnit, baseUnit, rtsUnit,
thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit
-primUnitName = fsLit "ghc-prim"
-bignumUnitName = fsLit "ghc-bignum"
-baseUnitName = fsLit "base"
-rtsUnitName = fsLit "rts"
-thisGhcUnitName = fsLit "ghc"
-interactiveUnitName = fsLit "interactive"
-thUnitName = fsLit "template-haskell"
-
-primUnitId = UnitId primUnitName
-bignumUnitId = UnitId bignumUnitName
-baseUnitId = UnitId baseUnitName
-rtsUnitId = UnitId rtsUnitName
-thisGhcUnitId = UnitId thisGhcUnitName
-interactiveUnitId = UnitId interactiveUnitName
+primUnitName = WiredInPackageName $ fsLit "ghc-prim"
+bignumUnitName = WiredInPackageName $ fsLit "ghc-bignum"
+baseUnitName = WiredInPackageName $ fsLit "base"
+rtsUnitName = WiredInPackageName $ fsLit "rts"
+thisGhcUnitName = WiredInPackageName $ fsLit "ghc"
+interactiveUnitName = WiredInPackageName $ fsLit "interactive"
+thUnitName = WiredInPackageName $ fsLit "template-haskell"
+
+primUnitId = mkWiredInUnitId primUnitName
+bignumUnitId = mkWiredInUnitId bignumUnitName
+baseUnitId = mkWiredInUnitId baseUnitName
+rtsUnitId = mkWiredInUnitId rtsUnitName
+thisGhcUnitId = mkWiredInUnitId thisGhcUnitName
+interactiveUnitId = UnitId $ wiredInPackageNameFS interactiveUnitName
thUnitId = mkWiredInUnitId thUnitName
{-# INLINE bignumUnitId #-}
{-# INLINE baseUnitId #-}
@@ -641,21 +648,21 @@ interactiveUnit = RealUnit (Definite interactiveUnitId)
-- | This is the package Id for the current program. It is the default
-- package Id if you don't specify a package name. We don't add this prefix
-- to symbol names, since there can be only one main package per program.
-mainUnitName = fsLit "main"
-mainUnitId = UnitId mainUnitName
+mainUnitName = WiredInPackageName $ fsLit "main"
+mainUnitId = UnitId $ wiredInPackageNameFS mainUnitName
mainUnit = RealUnit (Definite mainUnitId)
-- Make the actual unit id the result of looking up the wired-in unit package name in the wire map
-mkWiredInUnitId :: FastString -> UnitId
-mkWiredInUnitId x = case Map.lookup (UnitId x) $ unsafePerformIO (readIORef workingThisOut) of
- Nothing -> pprTrace "Romes:Couldn't find UnitId" (ppr (UnitId x,unsafePerformIO (readIORef workingThisOut))) (UnitId $ fsLit "rts") -- this is a fallback, in which situations do we need a fallback? perhaps when booting the compiler with the rts?
+mkWiredInUnitId :: WiredInPackageName -> UnitId
+mkWiredInUnitId x = case Map.lookup x $ unsafePerformIO (readIORef workingThisOut) of
+ Nothing -> pprTrace "Romes:Couldn't find UnitId" (ppr (x,unsafePerformIO (readIORef workingThisOut))) (UnitId $ fsLit "rts") -- this is a fallback, in which situations do we need a fallback? perhaps when booting the compiler with the rts?
Just y -> pprTrace "Romes:Found in wire map" (ppr x <+> text "->" <> ppr y) y
isInteractiveModule :: Module -> Bool
isInteractiveModule mod = moduleUnit mod == interactiveUnit
-wiredInUnitNames :: [FastString]
+wiredInUnitNames :: [WiredInPackageName]
wiredInUnitNames =
[ primUnitName
, bignumUnitName
=====================================
del-this-unit-id.sh
=====================================
@@ -0,0 +1 @@
+sed -i '' 's/ghc-options: -this-unit-id.*//i' compiler/ghc.cabal.in libraries/base/base.cabal libraries/ghc-bignum/ghc-bignum.cabal libraries/ghc-prim/ghc-prim.cabal rts/rts.cabal.in libraries/template-haskell/template-haskell.cabal.in
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22036aa2f01cb01a24cb203744ad4233dcd0b947
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22036aa2f01cb01a24cb203744ad4233dcd0b947
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230306/ccd12fc9/attachment-0001.html>
More information about the ghc-commits
mailing list