[Git][ghc/ghc][wip/romes/graph-compact-easy] Backwards compat revertions
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Dec 12 17:53:59 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/graph-compact-easy at Glasgow Haskell Compiler / GHC
Commits:
e20cd5f0 by Rodrigo Mesquita at 2024-12-12T17:53:33+00:00
Backwards compat revertions
- - - - -
10 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- docs/users_guide/9.14.1-notes.rst
- ghc/GHCi/UI.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -28,6 +28,9 @@ module GHC.Driver.Env
, lookupType
, lookupIfaceByModule
, mainModIs
+
+ -- * Legacy API
+ , hscUpdateHPT
)
where
@@ -326,3 +329,19 @@ discardIC hsc_env
where
home_unit = hsc_home_unit hsc_env
old_name = ic_name old_ic
+
+
+--------------------------------------------------------------------------------
+-- * The Legacy API, should be removed after enough deprecation cycles
+--------------------------------------------------------------------------------
+
+{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \
+ \ operation. Instead, the HPT is an insert-only data structure. If you want to \
+ \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \
+ \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-}
+hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
+hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue }
+ where
+ ue = hsc_unit_env hsc_env
+ upd hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) }
+
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -312,7 +312,7 @@ import GHC.Unit.Home.PackageTable
newHscEnv :: FilePath -> DynFlags -> IO HscEnv
newHscEnv top_dir dflags = do
- hpt <- newHomePackageTable
+ hpt <- emptyHomePackageTable
newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt)
where
home_unit_graph hpt = HUG.unitEnv_singleton
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -773,7 +773,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do
-- write an empty HPT to allow the old HPT to be GC'd.
let pruneHomeUnitEnv hme = do
- emptyHPT <- liftIO newHomePackageTable
+ emptyHPT <- liftIO emptyHomePackageTable
pure hme{ homeUnitEnv_hpt = emptyHPT }
hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph $ hsc_unit_env hsc_env)
let ue' = (hsc_unit_env hsc_env){ ue_home_unit_graph = hug' }
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -666,8 +666,8 @@ dontLeakTheHUG thing_inside = do
| hptHasHoles hpt = True
| otherwise = False
pruneHomeUnitEnv hme = do
- emptyHomePackageTable <- liftIO newHomePackageTable
- return hme{ homeUnitEnv_hpt = emptyHomePackageTable }
+ emptyHPT <- liftIO emptyHomePackageTable
+ return hme{ homeUnitEnv_hpt = emptyHPT }
unit_env_io
| keepFor20509 (ue_hpt old_unit_env)
= return old_unit_env
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -102,6 +102,12 @@ module GHC.Unit.Env
, hugAnnsBelow
, hugRulesBelow
, hugInstancesBelow
+
+
+ -- * Legacy API
+ --
+ -- | This API is deprecated!
+ , ue_units
)
where
@@ -471,3 +477,12 @@ There is also a template-haskell function, makeRelativeToProject, which uses the
in order to allow users to offset their own relative paths.
-}
+
+--------------------------------------------------------------------------------
+-- * Legacy API
+--------------------------------------------------------------------------------
+
+{-# DEPRECATED ue_units "Renamed to homeUnitState" #-}
+ue_units :: HasDebugCallStack => UnitEnv -> UnitState
+ue_units = homeUnitState
+
=====================================
compiler/GHC/Unit/Home/Graph.hs
=====================================
@@ -60,7 +60,10 @@ module GHC.Unit.Home.Graph
, unitEnv_foldWithKey
, unitEnv_singleton
, unitEnv_adjust
+ , unitEnv_keys
, unitEnv_insert
+ , unitEnv_new
+ , unitEnv_lookup
) where
import GHC.Prelude
@@ -298,6 +301,12 @@ newtype UnitEnvGraph v = UnitEnvGraph
{ unitEnv_graph :: Map UnitEnvGraphKey v
} deriving (Functor, Foldable, Traversable)
+unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v
+unitEnv_new m =
+ UnitEnvGraph
+ { unitEnv_graph = m
+ }
+
unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_insert unitId env unitEnv = unitEnv
{ unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv)
@@ -328,6 +337,9 @@ unitEnv_keys env = Map.keysSet (unitEnv_graph env)
unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g
+unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v
+unitEnv_lookup u env = expectJust "unitEnv_lookup" $ unitEnv_lookup_maybe u env
+
--------------------------------------------------------------------------------
-- * Utilities
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Unit/Home/PackageTable.hs
=====================================
@@ -39,7 +39,7 @@
module GHC.Unit.Home.PackageTable
(
HomePackageTable
- , newHomePackageTable
+ , emptyHomePackageTable
-- * Lookups in the HPT
, lookupHpt
@@ -47,6 +47,7 @@ module GHC.Unit.Home.PackageTable
-- * Extending the HPT
, addHomeModInfoToHpt
+ , addHomeModInfosToHpt
-- * Queries about home modules
, hptHasHoles
@@ -85,13 +86,19 @@ module GHC.Unit.Home.PackageTable
--
-- In GHC itself these should be avoided.
, hptInternalTableRef
+
+ -- * Legacy API
+ --
+ -- | This API is deprecated and meant to be removed.
+ , addToHpt
+ , addListToHpt
) where
import GHC.Prelude
import GHC.Data.Maybe
import Data.IORef
-import Control.Monad ((<$!>))
+import Control.Monad ((<$!>), foldM)
import qualified Data.Set as Set
import GHC.Core.FamInstEnv
@@ -158,9 +165,9 @@ data HomePackageTable = HPT {
-- Be careful not to share it across e.g. different units, since it uses a
-- mutable variable under the hood to keep the monotonically increasing list of
-- loaded modules.
-newHomePackageTable :: IO HomePackageTable
+emptyHomePackageTable :: IO HomePackageTable
-- romes:todo: use a MutableArray directly?
-newHomePackageTable = do
+emptyHomePackageTable = do
table <- newIORef emptyUDFM
return HPT{table, hasHoles=False, lastLoadedKey=Nothing}
@@ -187,22 +194,39 @@ lookupHptByModule hpt mod
-- | Add a new module to the HPT.
--
--- A very fundamental operation of the HPT!
+-- An HPT is a monotonically increasing data structure, holding information about loaded modules in a package.
+-- This is the main function by which the HPT is extended or updated.
+--
+-- When the module of the inserted 'HomeModInfo' does not exist, a new entry in
+-- the HPT is created for that module name.
+-- When the module already has an entry, inserting a new one entry in the HPT
+-- will always overwrite the existing entry for that module.
--
-- $O(1)$
addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> IO HomePackageTable
addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi
- where
- addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> IO HomePackageTable
- addToHpt HPT{table=hptr, hasHoles} mn hmi = do
- atomicModifyIORef' hptr (\hpt -> (addToUDFM hpt mn hmi, ()))
- -- If the key already existed in the map, this insertion is overwriting
- -- the HMI of a previously loaded module (likely in rehydration).
- return
- HPT{ table = hptr
- , hasHoles = hasHoles || isHoleModule (mi_semantic_module (hm_iface hmi))
- , lastLoadedKey = Just $! getUnique mn {- yes, even if we're overwriting something already in the map -}
- }
+
+{-# DEPRECATED addToHpt "Deprecated in favour of 'addHomeModInfoToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-}
+-- After deprecation cycle, move `addToHpt` to a `where` clause inside `addHomeModInfoToHpt`.
+addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> IO HomePackageTable
+addToHpt HPT{table=hptr, hasHoles} mn hmi = do
+ atomicModifyIORef' hptr (\hpt -> (addToUDFM hpt mn hmi, ()))
+ -- If the key already existed in the map, this insertion is overwriting
+ -- the HMI of a previously loaded module (likely in rehydration).
+ return
+ HPT{ table = hptr
+ , hasHoles = hasHoles || isHoleModule (mi_semantic_module (hm_iface hmi))
+ , lastLoadedKey = Just $! getUnique mn {- yes, even if we're overwriting something already in the map -}
+ }
+
+-- | 'addHomeModInfoToHpt' for multiple module infos.
+addHomeModInfosToHpt :: HomePackageTable -> [HomeModInfo] -> IO HomePackageTable
+addHomeModInfosToHpt hpt = foldM (flip addHomeModInfoToHpt) hpt
+
+{-# DEPRECATED addListToHpt "Deprecated in favour of 'addHomeModInfosToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-}
+-- After deprecation cycle, remove.
+addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> IO HomePackageTable
+addListToHpt hpt = foldM (uncurry . addToHpt) hpt
----------------------------------------------------------------------------------
---- * Queries
@@ -420,7 +444,7 @@ pprHPT HPT{table=hptr} = do
-- listHMIToHpt :: [HomeModInfo] -> HomePackageTable
----------------------------------------------------------------------------------
--- Would be fine, but may lead to bad utilization
+-- Would be fine, but may lead to linearly traversing the HPT unnecessarily
-- (e.g. `lastLoadedKey` superseded bad usages)
----------------------------------------------------------------------------------
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -47,6 +47,16 @@ Cmm
``ghc`` library
~~~~~~~~~~~~~~~
+- `addToHpt` and `addListToHPT` were moved from `GHC.Unit.Home.ModInfo` to `GHC.Unit.Home.PackageTable` and deprecated in favour of `addHomeModInfoToHpt` and `addHomeModInfosToHpt`.
+- `UnitEnvGraph` and operations `unitEnv_lookup_maybe`, `unitEnv_foldWithKey, `unitEnv_singleton`, `unitEnv_adjust`, `unitEnv_insert`, `unitEnv_new` were moved from `GHC.Unit.Env` to `GHC.Unit.Home.Graph`.
+- The HomePackageTable (HPT) is now exported from `GHC.Unit.Home.PackageTable`,
+ and is now backed by an IORef to avoid by construction very bad memory leaks.
+ This means the API to the HPT now is for the most part in IO. For instance,
+ `emptyHomePackageTable` and `addHomeModInfoToHpt` are now in IO.
+- `mkHomeUnitEnv` was moved to `GHC.Unit.Home.PackageTable`, and now takes two
+ extra explicit arguments. To restore previous behaviour, pass `emptyUnitState`
+ and `Nothing` as the first two arguments additionally.
+
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -4495,7 +4495,7 @@ discardInterfaceCache =
clearHPTs :: GhciMonad m => m ()
clearHPTs = do
let pruneHomeUnitEnv hme = liftIO $ do
- emptyHpt <- newHomePackageTable
+ emptyHpt <- emptyHomePackageTable
pure hme{ homeUnitEnv_hpt = emptyHpt }
discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG }
modifySessionM $ \hsc_env -> do
=====================================
ghc/Main.hs
=====================================
@@ -852,12 +852,12 @@ initMulti unitArgsFiles = do
(dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
- emptyHomePackageTable <- liftIO $ newHomePackageTable
+ emptyHpt <- liftIO $ emptyHomePackageTable
pure $ HomeUnitEnv
{ homeUnitEnv_units = unit_state
, homeUnitEnv_unit_dbs = Just dbs
, homeUnitEnv_dflags = updated_dflags
- , homeUnitEnv_hpt = emptyHomePackageTable
+ , homeUnitEnv_hpt = emptyHpt
, homeUnitEnv_home_unit = Just home_unit
}
@@ -954,7 +954,7 @@ offsetDynFlags dflags =
createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
createUnitEnvFromFlags unitDflags = do
unitEnvList <- forM unitDflags $ \dflags -> do
- emptyHpt <- newHomePackageTable
+ emptyHpt <- emptyHomePackageTable
let newInternalUnitEnv =
HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing
return (homeUnitId_ dflags, newInternalUnitEnv)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e20cd5f0ff606ae9d110c018027afb6380e258d0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e20cd5f0ff606ae9d110c018027afb6380e258d0
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/20241212/6021b0d3/attachment-0001.html>
More information about the ghc-commits
mailing list