Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC

Commits:

16 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do
    671 671 
       logger <- getLogger
    672 672 
       hsc_env <- getSession
    673 673
    674 
    -  (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)
    674 
    +  (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hsc_all_home_unit_ids hsc_env)
    675 675 
       updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
    676 676
    677 677 
       let upd hue =
    ... ... @@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
    760 760 
                   old_hpt = homeUnitEnv_hpt homeUnitEnv
    761 761 
                   home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)
    762 762
    763 
    -          (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) (ue_eud old_unit_env) home_units
    763 
    +          (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) home_units
    764 764
    765 765 
               updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
    766 766 
               pure HomeUnitEnv
    ... ... @@ -778,7 +778,6 @@ setProgramDynFlags_ invalidate_needed dflags = do
    778 778 
                   , ue_current_unit    = ue_currentUnit old_unit_env
    779 779 
                   , ue_module_graph    = ue_module_graph old_unit_env
    780 780 
                   , ue_eps             = ue_eps old_unit_env
    781 
    -              , ue_eud             = ue_eud old_unit_env
    782 781 
                   , ue_uic      = ue_uic old_unit_env
    783 782 
                   }
    784 783 
             modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
    ... ... @@ -837,7 +836,6 @@ setProgramHUG_ invalidate_needed new_hug0 = do
    837 836 
                 , ue_current_unit    = ue_currentUnit unit_env0
    838 837 
                 , ue_eps             = ue_eps unit_env0
    839 838 
                 , ue_module_graph    = ue_module_graph unit_env0
    840 
    -            , ue_eud             = ue_eud unit_env0
    841 839 
                 , ue_uic      = ue_uic unit_env0
    842 840 
                 }
    843 841 
           modifySession $ \h ->
    ... ... @@ -886,7 +884,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
    886 884 
               old_hpt = homeUnitEnv_hpt homeUnitEnv
    887 885 
               home_units = HUG.allUnits (ue_home_unit_graph unit_env)
    888 886
    889 
    -      (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) (ue_eud unit_env) home_units
    887 
    +      (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) home_units
    890 888
    891 889 
           updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    892 890 
           pure HomeUnitEnv

  • compiler/GHC/Driver/Backpack.hs
    ... ... @@ -92,7 +92,7 @@ import GHC.Types.Error (mkUnknownDiagnostic)
    92 92 
     import qualified GHC.Unit.Home.Graph as HUG
    93 93 
     import GHC.Unit.Home.ModInfo
    94 94 
     import GHC.Unit.Home.PackageTable
    95 
    -import GHC.Unit.External.Database (cacheExternalUnitDatabase)
    95 
    +import GHC.Unit.External.Index (cacheExternalUnitDatabase)
    96 96
    97 97 
     -- | Entry point to compile a Backpack file.
    98 98 
     doBackpack :: [FilePath] -> Ghc ()
    ... ... @@ -442,8 +442,8 @@ addInMemoryDatabase dflags u = do
    442 442 
               { unitDatabasePath  = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags (ppr (unitId u)) ++ ")"
    443 443 
               , unitDatabaseUnits = [u]
    444 444 
               }
    445 
    -    let eud = hscEUDC hsc_env
    446 
    -    liftIO $ cacheExternalUnitDatabase eud newdb
    445 
    +    let uic = hscUIC hsc_env
    446 
    +    liftIO $ cacheExternalUnitDatabase uic newdb
    447 447 
         -- added at the end because ordering matters
    448 448 
         pure dflags
    449 449 
               { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
    ... ... @@ -456,11 +456,10 @@ addUnit u = do
    456 456 
         logger <- getLogger
    457 457 
         let dflags0 = hsc_dflags hsc_env
    458 458 
         let old_unit_env = hsc_unit_env hsc_env
    459 
    -    let eud = hscEUDC hsc_env
    460 459
    461 460 
         dflags1 <- addInMemoryDatabase dflags0 u
    462 461
    463 
    -    (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) eud (hsc_all_home_unit_ids hsc_env)
    462 
    +    (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) (hsc_all_home_unit_ids hsc_env)
    464 463
    465 464
    466 465 
         -- update platform constants
    ... ... @@ -477,7 +476,6 @@ addUnit u = do
    477 476 
                         (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
    478 477 
               , ue_eps       = ue_eps old_unit_env
    479 478 
               , ue_module_graph = ue_module_graph old_unit_env
    480 
    -          , ue_eud       = ue_eud old_unit_env
    481 479 
               , ue_uic = ue_uic old_unit_env
    482 480 
               }
    483 481 
         setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }

  • compiler/GHC/Driver/Env.hs
    ... ... @@ -14,7 +14,6 @@ module GHC.Driver.Env
    14 14 
        , hsc_HUG
    15 15 
        , hsc_all_home_unit_ids
    16 16 
        , hscUnitIndex
    17 
    -   , hscUIC
    18 17 
        , hscUpdateLoggerFlags
    19 18 
        , hscUpdateHUG
    20 19 
        , hscInsertHPT
    ... ... @@ -27,7 +26,7 @@ module GHC.Driver.Env
    27 26 
        , runInteractiveHsc
    28 27 
        , hscEPS
    29 28 
        , hscEUD
    30 
    -   , hscEUDC
    29 
    +   , hscUIC
    31 30 
        , hscInterp
    32 31 
        , prepareAnnotations
    33 32 
        , discardIC
    ... ... @@ -228,10 +227,7 @@ hscEPS :: HscEnv -> IO ExternalPackageState
    228 227 
     hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))
    229 228
    230 229 
     hscEUD :: HscEnv -> IO (ExternalUnitDatabases UnitId)
    231 
    -hscEUD = readExternalUnitDatabases . hscEUDC
    232 
    -
    233 
    -hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId
    234 
    -hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env)
    230 
    +hscEUD = readExternalUnitDatabases . hscUIC
    235 231
    236 232 
     hscUnitIndex :: HscEnv -> IO UnitIndex
    237 233 
     hscUnitIndex hsc_env = ueUI (hsc_unit_env hsc_env)

  • compiler/GHC/Driver/Session/Units.hs
    ... ... @@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
    131 131 
       home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
    132 132 
         let hue_flags = homeUnitEnv_dflags homeUnitEnv
    133 133 
             dflags = homeUnitEnv_dflags homeUnitEnv
    134 
    -    (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) (hscEUDC hsc_env) home_units
    134 
    +    (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) home_units
    135 135
    136 136 
         updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    137 137 
         emptyHpt <- liftIO $ emptyHomePackageTable

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -178,19 +178,21 @@ data UnitEnv = UnitEnv
    178 178 
         , ue_namever   :: !GhcNameVersion
    179 179 
             -- ^ GHC name/version (used for dynamic library suffix)
    180 180
    181 
    -    , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId)
    182 
    -        -- ^ Global cache of already read package databases
    183 
    -
    184 181 
         , ue_uic :: {-# UNPACK #-} !UnitIndexCache
    185 
    -        -- ^ Index of already processed 'UnitInfo's.
    186 
    -        -- Shares state over all 'UnitState' in the 'HomeUnitGraph'.
    182 
    +        -- ^ Global index of already processed external units.
    183 
    +        -- Shares state over all 'UnitState's in the 'HomeUnitGraph'.
    184 
    +        --
    185 
    +        -- Allows sharing of 'UnitInfo's, ensuring each individual 'UnitInfo'
    186 
    +        -- is retained a constant number of times.
    187 
    +        --
    188 
    +        -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
    187 189 
         }
    188 190
    189 191 
     ueEPS :: UnitEnv -> IO ExternalPackageState
    190 192 
     ueEPS = eucEPS . ue_eps
    191 193
    192 194 
     ueEUD :: UnitEnv -> IO (ExternalUnitDatabases UnitId)
    193 
    -ueEUD = readExternalUnitDatabases . ue_eud
    195 
    +ueEUD = readExternalUnitDatabases . ue_uic
    194 196
    195 197 
     ueUI :: UnitEnv -> IO UnitIndex
    196 198 
     ueUI = readUnitIndex . ue_uic
    ... ... @@ -199,7 +201,6 @@ ueUI = readUnitIndex . ue_uic
    199 201 
     initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
    200 202 
     initUnitEnv cur_unit hug namever platform = do
    201 203 
       eps <- initExternalUnitCache
    202 
    -  eud <- initExternalUnitDatabaseCache
    203 204 
       uic <- initUnitIndexCache
    204 205 
       return $ UnitEnv
    205 206 
         { ue_eps             = eps
    ... ... @@ -208,7 +209,6 @@ initUnitEnv cur_unit hug namever platform = do
    208 209 
         , ue_current_unit    = cur_unit
    209 210 
         , ue_platform        = platform
    210 211 
         , ue_namever         = namever
    211 
    -    , ue_eud             = eud
    212 212 
         , ue_uic      = uic
    213 213 
         }
    214 214

  • compiler/GHC/Unit/External/Database.hs
    1 1 
     module GHC.Unit.External.Database (
    2 
    -  -- * Mutable cache for 'ExternalUnitDatabases'
    3 
    -  ExternalUnitDatabaseCache (..),
    4 
    -  initExternalUnitDatabaseCache,
    5 
    -  readExternalUnitDatabases,
    6 
    -  readExternalUnitDatabase,
    7 
    -  cacheExternalUnitDatabase,
    8 
    -  clearExternalUnitDatabaseCache,
    9 2 
       -- * 'ExternalUnitDatabases'
    10 3 
       ExternalUnitDatabases,
    11 4 
       emptyExternalUnitDatabases,
    12 5 
       insertExternalUnitDatabases,
    13 6 
       deleteExternalUnitDatabases,
    14 7 
       lookupExternalUnitDatabases,
    15 
    -  -- * 'UnitDatabase'
    8 
    +  -- * 'UnitDatabase' and how to merge them.
    16 9 
       UnitDatabase (..),
    17 10 
       mergeDatabases,
    18 11 
       UnitPrecedenceMap,
    ... ... @@ -20,8 +13,6 @@ module GHC.Unit.External.Database (
    20 13 
       compareByPreference,
    21 14 
       -- * Reading packages from disk.
    22 15 
       UnitDbConfig (..),
    23 
    -  readOrGetUnitDatabase,
    24 
    -  readUnitDatabases,
    25 16 
       readUnitDatabase,
    26 17 
       getUnitDbRefs,
    27 18 
       resolveUnitDatabase,
    ... ... @@ -48,8 +39,6 @@ import GHC.Utils.Panic
    48 39
    49 40 
     import Control.Monad
    50 41 
     import Data.Char
    51 
    -import Data.IORef
    52 
    -import Data.IORef qualified as IORef
    53 42 
     import Data.List (sortBy)
    54 43 
     import Data.Map.Strict (Map)
    55 44 
     import Data.Map.Strict qualified as Map
    ... ... @@ -60,40 +49,6 @@ import System.Directory
    60 49 
     import System.Environment (getEnv)
    61 50 
     import System.FilePath as FilePath
    62 51
    63 
    --- ----------------------------------------------------------------------------
    64 
    --- ExternalUnitDatabaseCache
    65 
    --- ----------------------------------------------------------------------------
    66 
    -
    67 
    --- | Mutable wrapper around 'ExternalUnitDatabases'.
    68 
    -newtype ExternalUnitDatabaseCache unit = ExternalUnitDatabaseCache
    69 
    -  { eudc_databases :: IORef (ExternalUnitDatabases unit)
    70 
    -  }
    71 
    -
    72 
    -initExternalUnitDatabaseCache :: IO (ExternalUnitDatabaseCache unit)
    73 
    -initExternalUnitDatabaseCache =
    74 
    -  ExternalUnitDatabaseCache <$> IORef.newIORef emptyExternalUnitDatabases
    75 
    -
    76 
    -readExternalUnitDatabases :: ExternalUnitDatabaseCache unit -> IO (ExternalUnitDatabases unit)
    77 
    -readExternalUnitDatabases eudc =
    78 
    -  IORef.readIORef (eudc_databases eudc)
    79 
    -
    80 
    -modifyExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> (ExternalUnitDatabases unit -> ExternalUnitDatabases unit) -> IO ()
    81 
    -modifyExternalUnitDatabaseCache eudc f =
    82 
    -  IORef.modifyIORef' (eudc_databases eudc) f
    83 
    -
    84 
    -readExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> OsPath -> IO (Maybe (UnitDatabase unit))
    85 
    -readExternalUnitDatabase eudc path = do
    86 
    -  dbs <- readExternalUnitDatabases eudc
    87 
    -  pure $ lookupExternalUnitDatabases path dbs
    88 
    -
    89 
    -cacheExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> UnitDatabase unit -> IO ()
    90 
    -cacheExternalUnitDatabase eudc db =
    91 
    -  modifyExternalUnitDatabaseCache eudc (insertExternalUnitDatabases db)
    92 
    -
    93 
    -clearExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> IO ()
    94 
    -clearExternalUnitDatabaseCache eudc =
    95 
    -  modifyExternalUnitDatabaseCache eudc (const emptyExternalUnitDatabases)
    96 
    -
    97 52 
     -- ----------------------------------------------------------------------------
    98 53 
     -- ExternalUnitDatabases
    99 54 
     -- ----------------------------------------------------------------------------
    ... ... @@ -230,12 +185,6 @@ data UnitDbConfig = UnitDbConfig
    230 185 
       , unitDbConfigGHCDir :: FilePath
    231 186 
       }
    232 187
    233 
    -readUnitDatabases :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> IO [UnitDatabase UnitId]
    234 
    -readUnitDatabases logger db_cache cfg = do
    235 
    -  conf_refs <- getUnitDbRefs cfg
    236 
    -  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
    237 
    -  mapM (readOrGetUnitDatabase logger db_cache cfg) confs
    238 
    -
    239 188 
     getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]
    240 189 
     getUnitDbRefs cfg = do
    241 190 
       let system_conf_refs = [UserPkgDb, GlobalPkgDb]
    ... ... @@ -285,17 +234,6 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
    285 234 
       if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
    286 235 
     resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
    287 236
    288 
    --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
    289 
    -readOrGetUnitDatabase :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
    290 
    -readOrGetUnitDatabase logger db_cache cfg conf_file =
    291 
    -  readExternalUnitDatabase db_cache conf_file >>= \ case
    292 
    -    Nothing -> do
    293 
    -      new_db <- readUnitDatabase logger cfg conf_file
    294 
    -      cacheExternalUnitDatabase db_cache new_db
    295 
    -      pure new_db
    296 
    -    Just db ->
    297 
    -      pure db
    298 
    -
    299 237 
     -- | Read the 'UnitDatabase' at the given location.
    300 238 
     readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
    301 239 
     readUnitDatabase logger cfg conf_file = do

  • compiler/GHC/Unit/External/Index.hs
    1 
    +-- | The 'UnitIndex' is a 'UnitEnv' wide data structure that shares
    2 
    +-- external unit information across the 'UnitState' of all home units
    3 
    +-- (e.g., 'HomeUnitEnv') in a particular 'UnitEnv'.
    4 
    +--
    5 
    +-- It caches already read unit databases, all processed 'UnitInfo's and
    6 
    +-- the 'WireMap'.
    7 
    +--
    8 
    +-- This module is meant to be imported as @Index@.
    9 
    +--
    10 
    +-- A short overview of how the different types here related to 'UnitState', 'UnitEnv'
    11 
    +-- and the 'HomeUnitEnv'.
    12 
    +--
    13 
    +-- ┌─────────┐
    14 
    +-- │ UnitEnv │
    15 
    +-- └────┬────┘
    16 
    +--      ├───────────────────────┐
    17 
    +--      │                       │
    18 
    +-- ┌────▼──────┐          ┌─────▼─────┐
    19 
    +-- │HomeUnitEnv│          │ UnitIndex ├────────────────┐
    20 
    +-- └────┬──────┘          └───────────┘                │
    21 
    +--      │                                              │
    22 
    +--      │      Reads cached unit DBs                   │
    23 
    +-- ┌────▼──────┐          ┌─────────────────────┐      │
    24 
    +-- │ UnitState ├──────────>ExternalUnitDatabases◄──────┤
    25 
    +-- └────┬──┬───┘          └─────────────────────┘      │
    26 
    +--      │  └───────────────────────┐                   │
    27 
    +--      │   Writes new UnitInfos   │                   │
    28 
    +--      │   during initialisation  │                   │
    29 
    +-- ┌────▼────────┐        ┌────────v──────────┐        │
    30 
    +-- │ UnitInfoMap │        │ GlobalUnitInfoMap ◄────────┘
    31 
    +-- └────┬────────┘        └────────^──────────┘
    32 
    +--      │                          │
    33 
    +--      └──────────────────────────┘
    34 
    +--          UnitInfoMap references
    35 
    +--          GlobalUnitInfoMap values
    36 
    +--          (All UnitInfos are shared)
    37 
    +--
    38 
    +-- Open arrow @A ───> B@: A uses B.
    39 
    +-- Closed arrow @A ◄─── B@: A is a field of B.
    40 
    +--
    41 
    +-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more technical discussion
    42 
    +-- about sharing 'UnitInfo's.
    1 43 
     module GHC.Unit.External.Index (
    2 44 
       -- * The 'UnitIndexCache'.
    3 45 
       -- A mutable wrapper around 'UnitIndex'
    ... ... @@ -6,12 +48,16 @@ module GHC.Unit.External.Index (
    6 48 
       readUnitIndex,
    7 49 
       modifyUnitIndexCache,
    8 50 
       clearUnitIndexCache,
    51 
    +  cacheExternalUnitDatabase,
    52 
    +  readExternalUnitDatabases,
    53 
    +  readExternalUnitDatabase,
    9 54 
       -- * 'UnitIndex'
    10 55 
       UnitIndex,
    11 56 
       emptyUnitIndex,
    12 57 
       wiringMap,
    13 58 
       unwiringMap,
    14 59 
       globalUnits,
    60 
    +  externalUnitDatabases,
    15 61 
       setWireMap,
    16 62 
       wireMapExists,
    17 63 
       addUnitInfoMap,
    ... ... @@ -32,10 +78,14 @@ module GHC.Unit.External.Index (
    32 78 
       updateWiredInUnits,
    33 79 
       updateWiredInUnitsInUnitInfo,
    34 80 
       updateWiredInUnitIdInModule,
    81 
    +  -- * Reading external unit databases into the 'UnitIndexCache'
    82 
    +  readOrGetUnitDatabase,
    83 
    +  readUnitDatabases,
    35 84 
     ) where
    36 85
    37 86 
     import GHC.Prelude
    38 87
    88 
    +import GHC.Data.OsPath
    39 89 
     import GHC.Data.ShortText qualified as ST
    40 90 
     import GHC.Types.Unique.Map
    41 91 
     import GHC.Unit.Database
    ... ... @@ -46,17 +96,36 @@ import GHC.Unit.Info
    46 96 
     import GHC.Unit.Types
    47 97 
     import GHC.Utils.Logger
    48 98
    99 
    +import Control.Monad (liftM)
    49 100 
     import Data.Either
    50 101 
     import Data.IORef (IORef)
    51 102 
     import Data.IORef qualified as IORef
    52 103 
     import Data.Map.Strict (Map)
    53 104 
     import Data.Map.Strict qualified as Map
    105 
    +import Data.Maybe (catMaybes)
    54 106
    55 107 
     -- ----------------------------------------------------------------------------
    56 108 
     -- UnitIndex
    57 109 
     -- ----------------------------------------------------------------------------
    58 110
    59 111 
     -- | Mutable version of 'UnitIndex'.
    112 
    +--
    113 
    +-- The 'UnitIndexCache' ensures that all calls to 'initUnits' will
    114 
    +-- share the 'UnitInfo' if it is possible.
    115 
    +--
    116 
    +-- To share the 'UnitInfo', the 'UnitInfo' needs to be fully-resolved, i.e., its wired-in
    117 
    +-- dependencies and modules need to be replaced with the 'UnitId' of the wired-in unit.
    118 
    +-- Thus, the 'UnitIndexCache' caches both the global 'WireMap' and the 'UnitInfoMap'.
    119 
    +--
    120 
    +-- The 'WireMap' is globally valid, as other parts of the compiler rely on the fact
    121 
    +-- that only one instance of wired-in units is used.
    122 
    +--
    123 
    +-- Memory Invariant: The 'UnitIndexCache' is the root object for retaining fully-resolved
    124 
    +-- 'UnitInfo'. 'UnitState' is expected to reference only 'UnitInfo's from the 'UnitIndexCache'.
    125 
    +-- There is exactly one fully-resolved 'UnitInfo' alive for each external unit per unit database.
    126 
    +--
    127 
    +-- A second instance may or may not be stored in the 'externalUnitDatabases', which represent the
    128 
    +-- in-memory cache of the on-disk unit databases.
    60 129 
     newtype UnitIndexCache = UnitIndexCache
    61 130 
       { uic_index :: IORef UnitIndex
    62 131 
       }
    ... ... @@ -66,21 +135,41 @@ initUnitIndexCache =
    66 135 
       UnitIndexCache <$> IORef.newIORef emptyUnitIndex
    67 136
    68 137 
     readUnitIndex :: UnitIndexCache -> IO UnitIndex
    69 
    -readUnitIndex eudc =
    70 
    -  IORef.readIORef (uic_index eudc)
    138 
    +readUnitIndex uic =
    139 
    +  IORef.readIORef (uic_index uic)
    71 140
    72 141 
     modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
    73 
    -modifyUnitIndexCache eudc f =
    74 
    -  IORef.modifyIORef' (uic_index eudc) f
    142 
    +modifyUnitIndexCache uic f =
    143 
    +  IORef.modifyIORef' (uic_index uic) f
    75 144
    76 145 
     clearUnitIndexCache :: UnitIndexCache -> IO ()
    77 
    -clearUnitIndexCache eudc =
    78 
    -  modifyUnitIndexCache eudc (const emptyUnitIndex)
    146 
    +clearUnitIndexCache uic =
    147 
    +  modifyUnitIndexCache uic (const emptyUnitIndex)
    148 
    +
    149 
    +cacheExternalUnitDatabase :: UnitIndexCache -> UnitDatabase UnitId -> IO ()
    150 
    +cacheExternalUnitDatabase uic db =
    151 
    +  modifyUnitIndexCache uic
    152 
    +    (\ ui ->
    153 
    +      ui
    154 
    +        { ui_externalUnitDatabases = insertExternalUnitDatabases db (ui_externalUnitDatabases ui)
    155 
    +        }
    156 
    +    )
    157 
    +
    158 
    +readExternalUnitDatabases :: UnitIndexCache -> IO (ExternalUnitDatabases UnitId)
    159 
    +readExternalUnitDatabases uic =
    160 
    +  externalUnitDatabases <$> readUnitIndex uic
    161 
    +
    162 
    +readExternalUnitDatabase :: UnitIndexCache -> OsPath -> IO (Maybe (UnitDatabase UnitId))
    163 
    +readExternalUnitDatabase uic path = do
    164 
    +  dbs <- readExternalUnitDatabases uic
    165 
    +  pure $ lookupExternalUnitDatabases path dbs
    79 166
    80 167 
     -- | Global index for external units that can be shared across multiple 'HomeUnitEnv's.
    81 168 
     --
    82 169 
     -- Allows sharing of the 'WireMap' and 'UnitInfo's that are stored in the 'UnitState'
    83 170 
     -- of each 'HomeUnitEnv'.
    171 
    +--
    172 
    +-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details about memory usage.
    84 173 
     data UnitIndex = UnitIndex
    85 174 
       { ui_wireMap :: !WireMap
    86 175 
         -- ^ A mapping from database unit keys to wired in unit ids.
    ... ... @@ -95,10 +184,13 @@ data UnitIndex = UnitIndex
    95 184 
       , ui_unitInfoMap :: !GlobalUnitInfoMap
    96 185 
         -- ^ A global map for all fully-resolved 'UnitInfo's.
    97 186 
         --
    98 
    -    -- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
    99 
    -    -- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
    100 
    -    -- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
    101 
    -    -- variables such as @${pkgroot}@ in paths.
    187 
    +    -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more details
    188 
    +    -- what we use this for and what a fully-resolved 'UnitInfo' is.
    189 
    +  , ui_externalUnitDatabases :: !(ExternalUnitDatabases UnitId)
    190 
    +    -- ^ Cache the already processed unit databases in-memory.
    191 
    +    --
    192 
    +    -- These 'GenericUnitInfo's have their paths resolved, e.g., no @${pkgroot}@ is
    193 
    +    -- present any more.
    102 194 
       }
    103 195
    104 196 
     -- | Get the 'WireMap'.
    ... ... @@ -115,7 +207,18 @@ wiringMap = ui_wireMap
    115 207 
     unwiringMap :: UnitIndex -> UnwireMap
    116 208 
     unwiringMap = ui_unwireMap
    117 209
    210 
    +-- | Access the already processed unit databases.
    211 
    +externalUnitDatabases :: UnitIndex -> ExternalUnitDatabases UnitId
    212 
    +externalUnitDatabases = ui_externalUnitDatabases
    213 
    +
    118 214 
     -- | Access the global map of fully-resolved 'UnitInfo's.
    215 
    +--
    216 
    +-- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
    217 
    +-- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
    218 
    +-- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
    219 
    +-- variables such as @${pkgroot}@ in paths.
    220 
    +--
    221 
    +-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for why this is helpful.
    119 222 
     globalUnits :: UnitIndex -> GlobalUnitInfoMap
    120 223 
     globalUnits = ui_unitInfoMap
    121 224
    ... ... @@ -124,6 +227,7 @@ emptyUnitIndex = UnitIndex
    124 227 
       { ui_wireMap = emptyWireMap
    125 228 
       , ui_unwireMap = emptyUnwireMap
    126 229 
       , ui_unitInfoMap = emptyGlobalUnitInfoMap
    230 
    +  , ui_externalUnitDatabases = emptyExternalUnitDatabases
    127 231 
       }
    128 232
    129 233 
     -- | Set the 'WireMap' of 'UnitIndex'.
    ... ... @@ -167,7 +271,8 @@ type UnitAbiHash = ST.ShortText
    167 271 
     --
    168 272 
     -- However, a user can choose a conflicting 'UnitId', causing a conflict after all.
    169 273 
     -- We use the 'UnitAbiHash' for disambiguation. If both 'UnitId' and 'UnitAbiHash' are
    170 
    --- identical in separate unit databases, we can assume they are the same unit.
    274 
    +-- identical in separate unit databases, we can assume they are the same unit, according
    275 
    +-- to the documentation of GHC.
    171 276 
     newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo))
    172 277
    173 278 
     -- | Lookup the 'UnitInfo' in the 'GlobalUnitInfoMap'.
    ... ... @@ -238,7 +343,10 @@ updateWiredInUnitIndex wired_map pkgs unit_index = do
    238 343 
       ui <- readUnitIndex unit_index
    239 344 
       let
    240 345 
         all_pkgs = updateWiredInUnits wired_map (ui_unitInfoMap ui) pkgs
    241 
    -    (new_pkgs, _pkgs_set) = partitionEithers all_pkgs
    346 
    +    (new_pkgs', _pkgs_set) = partitionEithers all_pkgs
    347 
    +  -- Make sure we force the 'UnitInfo' here.
    348 
    +  -- Otherwise, we will retain a reference to the old 'UnitInfo'
    349 
    +  new_pkgs <- traverse evaluateUnitInfoLists new_pkgs'
    242 350 
       modifyUnitIndexCache unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs)
    243 351 
       pure (map (either id id) all_pkgs)
    244 352
    ... ... @@ -310,3 +418,23 @@ upd_wired_in :: WireMap -> UnitId -> UnitId
    310 418 
     upd_wired_in wiredInMap key
    311 419 
         | Just key' <- lookupWireMap key wiredInMap = key'
    312 420 
         | otherwise = key
    421 
    +
    422 
    +-- -----------------------------------------------------------------------------
    423 
    +-- Reading the unit database(s) into the 'UnitIndexCache'
    424 
    +
    425 
    +readUnitDatabases :: Logger -> UnitIndexCache -> UnitDbConfig -> IO [UnitDatabase UnitId]
    426 
    +readUnitDatabases logger db_cache cfg = do
    427 
    +  conf_refs <- getUnitDbRefs cfg
    428 
    +  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
    429 
    +  mapM (readOrGetUnitDatabase logger db_cache cfg) confs
    430 
    +
    431 
    +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
    432 
    +readOrGetUnitDatabase :: Logger -> UnitIndexCache -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
    433 
    +readOrGetUnitDatabase logger db_cache cfg conf_file =
    434 
    +  readExternalUnitDatabase db_cache conf_file >>= \ case
    435 
    +    Nothing -> do
    436 
    +      new_db <- readUnitDatabase logger cfg conf_file
    437 
    +      cacheExternalUnitDatabase db_cache new_db
    438 
    +      pure new_db
    439 
    +    Just db ->
    440 
    +      pure db

  • compiler/GHC/Unit/External/ModuleOrigin.hs
    ... ... @@ -7,12 +7,12 @@ module GHC.Unit.External.ModuleOrigin (
    7 7 
       originEmpty,
    8 8 
     ) where
    9 9
    10 
    +import Data.Semigroup qualified as Semigroup
    10 11 
     import GHC.Prelude
    11 12 
     import GHC.Unit.External.Validate
    12 13 
     import GHC.Unit.Info
    13 14 
     import GHC.Utils.Outputable
    14 15 
     import GHC.Utils.Panic
    15 
    -import qualified Data.Semigroup as Semigroup
    16 16
    17 17 
     -- | Given a module name, there may be multiple ways it came into scope,
    18 18 
     -- possibly simultaneously.  This data type tracks all the possible ways

  • compiler/GHC/Unit/State.hs
    ... ... @@ -6,7 +6,6 @@ module GHC.Unit.State (
    6 6 
             module GHC.Unit.Info,
    7 7 
             -- * Reading the package config, and processing cmdline args
    8 8 
             UnitState(..),
    9 
    -        TrustOverlay(..),
    10 9 
             UnitDatabase (..),
    11 10 
             UnitErr (..),
    12 11 
             emptyUnitState,
    ... ... @@ -16,6 +15,13 @@ module GHC.Unit.State (
    16 15 
             getUnitDbRefs,
    17 16 
             resolveUnitDatabase,
    18 17 
             listUnitInfo,
    18 
    +        -- * Overlays over the unit set
    19 
    +        TrustOverlay,
    20 
    +        IsTrusted(..),
    21 
    +        lookupTrustOverlay,
    22 
    +        distrustUnits,
    23 
    +        trustUnits,
    24 
    +        emptyTrustOverlay,
    19 25 
             -- * Querying the package config
    20 26 
             lookupUnit,
    21 27 
             lookupUnit',
    ... ... @@ -252,12 +258,19 @@ data IsTrusted
    252 258 
       | Distrusted
    253 259 
       deriving ( Eq, Ord )
    254 260
    261 
    +-- | The 'TrustOverlay' stores user overwrites of the on-disk 'unitIsTrusted' status.
    262 
    +--
    263 
    +-- The user can overwrite this value via flags such as @-distrust-all-packages@.
    264 
    +-- We do not modify the 'UnitInfo' directory, but rather store this user selection
    265 
    +-- in the 'TrustOverlay'.
    266 
    +--
    267 
    +-- This allows us to share the 'UnitInfo' completely and saves us memory.
    255 268 
     newtype TrustOverlay = TrustOverlay
    256 269 
       { trustOverlay :: UniqMap UnitId IsTrusted
    257 270 
       }
    258 271
    259 272 
     lookupTrustOverlay :: TrustOverlay -> UnitId -> Maybe IsTrusted
    260 
    -lookupTrustOverlay (TrustOverlay to) = lookupUniqMap to
    273 
    +lookupTrustOverlay to = lookupUniqMap (trustOverlay to)
    261 274
    262 275 
     distrustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
    263 276 
     distrustUnits elements (TrustOverlay to) = TrustOverlay $ foldl' (\ acc uid -> addToUniqMap acc uid Distrusted) to elements
    ... ... @@ -268,6 +281,57 @@ trustUnits elements (TrustOverlay to) = TrustOverlay $ foldl' (\ acc uid -> addT
    268 281 
     emptyTrustOverlay :: TrustOverlay
    269 282 
     emptyTrustOverlay = TrustOverlay emptyUniqMap
    270 283
    284 
    +{-
    285 
    +Note [Sharing 'UnitInfo's across the 'UnitEnv']
    286 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    287 
    +The 'UnitState' and 'UnitIndex' are closely related.
    288 
    +
    289 
    +The 'UnitState' stores all information about the external units referenced by
    290 
    +a single 'HomeUnitEnv'.
    291 
    +As a reminder, the 'HomeUnitEnv' stores all information specific to a single home unit,
    292 
    +such as the 'HomePackageTable', 'DynFlags' and the 'UnitState'.
    293 
    +The 'UnitState' retains the 'unitInfoMap', an in-memory representation of
    294 
    +the unit databases that a 'HomeUnitEnv' depends on.
    295 
    +Multiple home units can depend on the same unit database, and reference the same
    296 
    +'UnitInfo's across the GHC session.
    297 
    +We share all 'UnitInfo's across multiple 'HomeUnitEnv's, saving a lot of
    298 
    +duplication of the same 'UnitInfo'.
    299 
    +This what the 'UnitIndex' takes care of.
    300 
    +
    301 
    +The 'UnitIndex' stores all fully-resolved 'UnitInfo's that can be referenced
    302 
    +by the 'UnitState'.'unitInfoMap'.
    303 
    +We consider a 'UnitInfo' as fully-resolved, if its dependencies were updated to reference the
    304 
    +wired-in units (e.g., 'wiringMap') and the wired-in units are updated as well.
    305 
    +See Note [Wired-in units] for more details on wired-in units.
    306 
    +Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
    307 
    +variables such as @${pkgroot}@ in paths.
    308 
    +
    309 
    +As such, we can consider the 'UnitIndex' to be global data that is referenced by
    310 
    +the 'UnitState' for better sharing of 'UnitInfo's.
    311 
    +
    312 
    +In fact, using the 'UnitIndex', we can impose a hard upper bound on the number
    313 
    +of live 'UnitInfo's in a GHC session:
    314 
    +
    315 
    +> For each on-disk 'GenericUnitInfo', there are at most two objects alive.
    316 
    +
    317 
    +One instance is stored in 'ExternalUnitDatabases' where variables are resolved,
    318 
    +but the wired-in units haven't been resolved.
    319 
    +
    320 
    +The second instance is the fully-resolved 'UnitInfo' stored in the 'UnitIndex'.
    321 
    +
    322 
    +See the module documentation for 'GHC.Unit.External.Index' for an overview
    323 
    +of how the types relate to each other.
    324 
    +-}
    325 
    +
    326 
    +-- | The 'UnitState' contains a plethora of information local to a single 'HomeUnitEnv'.
    327 
    +--
    328 
    +-- It stores module visibilities, unit trust for @SafeHaskell@, available units for error messages,
    329 
    +-- explicit unit dependencies and knows how to instantiate backpack signature and holes
    330 
    +-- on demand.
    331 
    +--
    332 
    +-- A 'HomeUnitEnv' should rarely/never have to look into the 'UnitIndex', all external
    333 
    +-- unit related information is stored in the 'UnitState'.
    334 
    +--
    271 335 
     data UnitState = UnitState {
    272 336 
       -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
    273 337 
       -- so that only valid units are here.  'UnitInfo' reflects
    ... ... @@ -276,6 +340,7 @@ data UnitState = UnitState {
    276 340 
       -- may have the 'exposed' flag be 'False'.)
    277 341 
       --
    278 342 
       -- All values are shared with 'UnitIndex'.'globalUnits'.
    343 
    +  -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
    279 344 
       unitInfoMap :: UnitInfoMap,
    280 345
    281 346 
       -- | Set of units that we trust.
    ... ... @@ -283,7 +348,10 @@ data UnitState = UnitState {
    283 348 
       -- Local overlay of 'UnitInfo'.
    284 349 
       -- This avoids modifying the 'UnitInfo' directly, potentially saving
    285 350 
       -- a lot of duplication.
    286 
    -  trustedUnits :: TrustOverlay,
    351 
    +  --
    352 
    +  -- We keep this in WHNF as it is relatively cheap but could easily retain
    353 
    +  -- references to bigger structures.
    354 
    +  trustedUnits :: !TrustOverlay,
    287 355
    288 356 
       -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
    289 357 
       -- package name (e.g. different instantiations), then we return one of them...
    ... ... @@ -333,8 +401,6 @@ emptyUnitState = UnitState {
    333 401 
         unitInfoMap    = emptyUniqMap,
    334 402 
         trustedUnits   = emptyTrustOverlay,
    335 403 
         packageNameMap = emptyUFM,
    336 
    -    -- wireMap        = emptyUniqMap,
    337 
    -    -- unwireMap      = emptyUniqMap,
    338 404 
         preloadUnits   = [],
    339 405 
         explicitUnits  = [],
    340 406 
         homeUnitDepends = Set.empty,
    ... ... @@ -439,14 +505,16 @@ isUnitInfoTrusted ue u =
    439 505 
     -- 'initUnits' can be called again subsequently after updating the
    440 506 
     -- 'packageFlags' and 'packageDBFlags' fields of the 'DynFlags', and it will
    441 507 
     -- update the 'unitState' in 'DynFlags'.
    442 
    -initUnits :: Logger -> DynFlags -> UnitIndexCache -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
    443 
    -initUnits logger dflags unit_index cached_dbs home_units = do
    508 
    +--
    509 
    +-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for implementation details.
    510 
    +initUnits :: Logger -> DynFlags -> UnitIndexCache -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
    511 
    +initUnits logger dflags unit_index home_units = do
    444 512
    445 513 
       let forceUnitInfoMap state = unitInfoMap state `seq` ()
    446 514
    447 515 
       unit_state <- withTiming logger (text "initializing unit database")
    448 516 
                        forceUnitInfoMap
    449 
    -                 $ mkUnitState logger unit_index cached_dbs (initUnitConfig dflags  home_units)
    517 
    +                 $ mkUnitState logger unit_index (initUnitConfig dflags  home_units)
    450 518
    451 519 
       putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
    452 520 
         FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
    ... ... @@ -638,10 +706,9 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs
    638 706 
     mkUnitState
    639 707 
         :: Logger
    640 708 
         -> UnitIndexCache
    641 
    -    -> ExternalUnitDatabaseCache UnitId
    642 709 
         -> UnitConfig
    643 710 
         -> IO UnitState
    644 
    -mkUnitState logger unit_index db_cache cfg = do
    711 
    +mkUnitState logger unit_index cfg = do
    645 712 
     {-
    646 713 
        Plan.
    647 714
    ... ... @@ -695,7 +762,7 @@ mkUnitState logger unit_index db_cache cfg = do
    695 762 
               we build a mapping saying what every in scope module name points to.
    696 763 
     -}
    697 764
    698 
    -  dbs <- readUnitDatabases logger db_cache (initUnitDbConfig cfg)
    765 
    +  dbs <- readUnitDatabases logger unit_index (initUnitDbConfig cfg)
    699 766
    700 767 
       -- distrust all units if the flag is set
    701 768 
       let distrustUnitsOfDb overlay db = foldl' (\ acc ui -> distrustUnits [unitId ui] acc) overlay (unitDatabaseUnits db)
    ... ... @@ -713,7 +780,7 @@ mkUnitState logger unit_index db_cache cfg = do
    713 780 
       debugTraceMsg logger 2 $
    714 781 
           text "package flags" <+> ppr other_flags
    715 782
    716 
    -  let !home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
    783 
    +  let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
    717 784
    718 785 
       -- Merge databases together, without checking validity
    719 786 
       (pkg_map1, prec_map) <- mergeDatabases logger dbs
    ... ... @@ -727,7 +794,7 @@ mkUnitState logger unit_index db_cache cfg = do
    727 794
    728 795 
       -- Compute trust flags (these flags apply regardless of whether
    729 796 
       -- or not packages are visible or not)
    730 
    -  !trustUnitsOverlay <- mayThrowUnitErr
    797 
    +  trustUnitsOverlay <- mayThrowUnitErr
    731 798 
                 $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
    732 799 
                      distrustedUnitsOverlay (reverse (unitConfigFlagsTrusted cfg))
    733 800 
       let pkgs1 = nonDetEltsUniqMap pkg_map2
    ... ... @@ -769,12 +836,12 @@ mkUnitState logger unit_index db_cache cfg = do
    769 836 
                                 -- Note: we NEVER expose indefinite packages by
    770 837 
                                 -- default, because it's almost assuredly not
    771 838 
                                 -- what you want (no mix-in linking has occurred).
    772 
    -                            let !x = fsPackageName p in if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
    839 
    +                            if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
    773 840 
                                    then addToUniqMap vm (mkUnit p)
    774 841 
                                                    UnitVisibility {
    775 842 
                                                      uv_expose_all = True,
    776 843 
                                                      uv_renamings = [],
    777 
    -                                                 uv_package_name = First (Just x),
    844 
    +                                                 uv_package_name = First (Just $ fsPackageName p),
    778 845 
                                                      uv_requirements = emptyUniqMap,
    779 846 
                                                      uv_explicit = Nothing
    780 847 
                                                    }

  • ghc/GHCi/UI.hs
    ... ... @@ -857,7 +857,7 @@ installInteractiveHomeUnits dflags = do
    857 857 
           env <- GHC.getSession
    858 858 
           let unit_index = hscUIC env
    859 859 
           (unit_state,home_unit,_mconstants) <-
    860 
    -        liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units
    860 
    +        liftIO $ initUnits logger dflags unit_index all_home_units
    861 861 
           hpt <- liftIO emptyHomePackageTable
    862 862 
           pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
    863 863

  • testsuite/tests/driver/TUnitInfo/Makefile
    ... ... @@ -2,17 +2,38 @@ TOP=../../..
    2 2 
     include $(TOP)/mk/boilerplate.mk
    3 3 
     include $(TOP)/mk/test.mk
    4 4
    5 
    -.PHONY: generic-unit-info-space_Prep
    6 
    -generic-unit-info-space_Prep:
    5 
    +.PHONY: generic-unit-info-space-single_Prep
    6 
    +generic-unit-info-space-single_Prep:
    7 7
    8 8
    9 
    -.PHONY: generic-unit-info-space
    10 
    -generic-unit-info-space:
    9 
    +.PHONY: generic-unit-info-space-single
    10 
    +generic-unit-info-space-single:
    11 11 
     	"$(TEST_HC)" $(TEST_HC_OPTS) -Wall -v0 generic-unit-info-space.hs -rtsopts \
    12 12 
     		-package ghc -package base -package ghc-internal -threaded
    13 13
    14 14 
     	./generic-unit-info-space$(exeext) \
    15 15 
     		"`'$(TEST_HC)' --print-libdir | tr -d '\r'`" \
    16 16 
     		"`'$(GHC_PKG)' --no-user-package-db list --simple-output | wc -w`" \
    17 
    +		-clear-package-db -global-package-db -no-user-package-db \
    18 
    +		+RTS -hT --no-automatic-heap-samples -RTS
    19 
    +
    20 
    +# Generate 50 trivial home units. The number of 'UnitInfo's must not increase
    21 
    +# linearly in the number of home units
    22 
    +HOME_UNITS_01 := 50
    23 
    +UNITS := $(foreach p,$(shell seq 0 $$(( $(HOME_UNITS_01) - 1 ))),-unit @unitp$(p))
    24 
    +.PHONY: generic-unit-info-space-mhu_Prep
    25 
    +generic-unit-info-space-mhu_Prep:
    26 
    +	./genMhu.sh $(HOME_UNITS_01)
    27 
    +
    28 
    +
    29 
    +.PHONY: generic-unit-info-space-mhu
    30 
    +generic-unit-info-space-mhu:
    31 
    +	"$(TEST_HC)" $(TEST_HC_OPTS) -Wall -v0 generic-unit-info-space.hs -rtsopts \
    32 
    +		-package ghc -package base -package ghc-internal -threaded
    33 
    +
    34 
    +	./generic-unit-info-space$(exeext) \
    35 
    +		"`'$(TEST_HC)' --print-libdir | tr -d '\r'`" \
    36 
    +		"`'$(GHC_PKG)' --global list --simple-output | wc -w`" \
    37 
    +		$(UNITS) \
    17 38 
     		+RTS -hT --no-automatic-heap-samples -RTS
    18 39

  • testsuite/tests/driver/TUnitInfo/all.T
    1 1 
     # A test for checking the number of live GenericUnitInfo objects
    2 
    -test('generic-unit-info-space'
    3 
    -    , [ extra_files(['Foo.hs'])
    4 
    -      , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space_Prep')
    2 
    +test('generic-unit-info-space-single'
    3 
    +    , [ extra_files(['Foo.hs', 'generic-unit-info-space.hs'])
    4 
    +      , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space-single_Prep')
    5 5 
           ]
    6 6 
         , makefile_test
    7 
    -    , ['generic-unit-info-space'])
    7 
    +    , ['generic-unit-info-space-single'])
    8 
    +
    9 
    +# A test for checking the number of live GenericUnitInfo objects
    10 
    +test('generic-unit-info-space-mhu'
    11 
    +    , [ extra_files(['genMhu.sh', 'generic-unit-info-space.hs'])
    12 
    +      , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space-mhu_Prep')
    13 
    +      ]
    14 
    +    , makefile_test
    15 
    +    , ['generic-unit-info-space-mhu'])

  • testsuite/tests/driver/TUnitInfo/genMhu.sh
    1 
    +#! /usr/bin/env bash
    2 
    +
    3 
    +set -euo pipefail
    4 
    +
    5 
    +HOME_UNITS=${1:-50}
    6 
    +
    7 
    +unit_dir()  { echo "p$1"; }
    8 
    +unit_fname(){ echo "unitp$1"; }
    9 
    +mod_name() { echo "Mod$1"; }
    10 
    +
    11 
    +mk_unit_file() {
    12 
    +    local p=$1
    13 
    +    echo "-clear-package-db -global-package-db -no-user-package-db -working-dir $(unit_dir "$p") -this-unit-id $(unit_dir "$p") $(mod_name "$p") ${deps[*]}" \
    14 
    +        > "$(unit_fname "$p")"
    15 
    +}
    16 
    +
    17 
    +mk_top_mod() {
    18 
    +    local p=$1
    19 
    +    echo "module $(mod_name "$p") where" > "$(unit_dir "$p")/$(mod_name "$p").hs"
    20 
    +}
    21 
    +
    22 
    +for ((p = 0; p < HOME_UNITS; p++)); do
    23 
    +    mkdir "$(unit_dir "$p")"
    24 
    +    mk_unit_file "$p"
    25 
    +    mk_top_mod "$p"
    26 
    +done

  • testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
    1 
    +### Heap Census
    2 
    +There are exactly two GenericUnitInfo closures alive per on-disk package

  • testsuite/tests/driver/TUnitInfo/generic-unit-info-space-single.stdout
    1 
    +### Heap Census
    2 
    +There are exactly two GenericUnitInfo closures alive per on-disk package

  • testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
    ... ... @@ -6,6 +6,7 @@ import GHC.Data.FastString (mkFastStringByteString)
    6 6 
     import qualified GHC.Data.ShortText as ST
    7 7 
     import GHC.Driver.Monad
    8 8 
     import GHC.Driver.Env.Types
    9 
    +import GHC.Driver.Session.Units
    9 10 
     import GHC.Internal.Heap.Closures (closureSize, asBox)
    10 11 
     import GHC.Platform
    11 12 
     import GHC.Profiling
    ... ... @@ -14,6 +15,7 @@ import GHC.Unit.Types (stringToUnitId)
    14 15
    15 16 
     import Control.Monad (guard, when)
    16 17 
     import Data.Version (makeVersion)
    18 
    +import qualified Data.List.NonEmpty as NE
    17 19 
     import qualified Data.Maybe as Maybe
    18 20 
     import qualified Data.List as List
    19 21 
     import System.Environment
    ... ... @@ -24,19 +26,32 @@ main :: IO ()
    24 26 
     main = do
    25 27 
         libdir:numberOfGlobalPkgsStr:restArgs <- getArgs
    26 28 
         runGhc (Just libdir) $ do
    27 
    -      initGhcM (read numberOfGlobalPkgsStr) $ ["-clear-package-db", "-global-package-db", "-no-user-package-db"] ++ restArgs
    28 
    -
    29 
    +      initGhcM (read numberOfGlobalPkgsStr) restArgs
    29 30
    30 31 
     initGhcM :: Int -> [String] -> Ghc ()
    31 32 
     initGhcM numOfPkgs xs = do
    32 33 
         session <- getSession
    33 34 
         df1 <- getSessionDynFlags
    34 
    -    let cmdOpts = ["-fforce-recomp"] ++ xs
    35 
    +    let (units, args) = extractUnits xs
    36 
    +    let cmdOpts = ["-fforce-recomp"]  ++ args
    37 
    +
    35 38 
         (df2, leftovers, _) <- parseDynamicFlags (hsc_logger session) df1 (map noLoc cmdOpts)
    36 39 
         setSessionDynFlags df2
    37 
    -    ts <- mapM (\s -> guessTarget s Nothing Nothing) $ map unLoc leftovers
    38 
    -    setTargets ts
    39 
    -    _ <- load LoadAllTargets
    40 
    +
    41 
    +    targets <- case NE.nonEmpty units of
    42 
    +      Nothing ->
    43 
    +        traverse (\s -> guessTarget s Nothing Nothing) $ map unLoc leftovers
    44 
    +      Just mhu -> do
    45 
    +        ts <- initMulti mhu (\ _ _ _ _ -> pure ())
    46 
    +        traverse (\(n, mu, mp) -> guessTarget n mu mp) ts
    47 
    +
    48 
    +    setTargets targets
    49 
    +    success <- load LoadAllTargets
    50 
    +
    51 
    +    liftIO $ when (failed success) $ do
    52 
    +      putStrLn "Failed to load targets"
    53 
    +      Exit.exitFailure
    54 
    +
    40 55 
         liftIO $ do
    41 56 
           requestHeapCensus
    42 57 
           performGC
    ... ... @@ -64,15 +79,17 @@ initGhcM numOfPkgs xs = do
    64 79 
           -- The output should be:
    65 80 
           --
    66 81 
           -- @
    67 
    -      --   2 * number of packages in global unit db * 8 * word_size * sizeof(struct GenericUnitInfo)
    82 
    +      --   2 * number of packages in global unit db * word_size * sizeof(struct GenericUnitInfo)
    68 83 
           -- @
    69 84 
           --
    70 
    -      -- This test simply assures, that in a single home unit case, we don't leak 'UnitInfo's
    85 
    +      -- This test simply assures, that when we load a session, we don't leak 'UnitInfo's
    71 86 
           --
    72 
    -      -- If this number changes for any reason, DO NOT ACCEPT THE CHANGES, you have introduced a space leak.
    73 
    -      when (num /= expectedSizeInBytes) $ do
    87 
    +      -- If this number changes without a good reason, DO NOT ACCEPT THE CHANGES, you have introduced a space leak.
    88 
    +      -- We say less than the expected size is accepted, because in the multiple-home-units case, we don't force the second
    89 
    +      -- UnitInfo closure enough after initial processing.
    90 
    +      when (num > expectedSizeInBytes) $ do
    74 91 
             putStrLn "Space leak detected by generic-unit-info-space test:"
    75 
    -        putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when == (" ++ show expectedNumberOfUnitInfos ++ ") are expected"
    92 
    +        putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when <= (" ++ show expectedNumberOfUnitInfos ++ ") are expected"
    76 93 
             readFile hpFile >>= putStrLn
    77 94 
             Exit.exitFailure
    78 95 
         return ()
    ... ... @@ -135,3 +152,11 @@ minimalUnitInfo = GenericUnitInfo
    135 152 
       , unitIsExposed           = True
    136 153 
       , unitIsTrusted           = False
    137 154 
       }
    155 
    +
    156 
    +extractUnits :: [String] -> ([String], [String])
    157 
    +extractUnits = go [] []
    158 
    +  where
    159 
    +    -- TODO: we should likely use the 'processCmdLineP' instead
    160 
    +    go units rest ("-unit" : x : xs) = go (x : units) rest xs
    161 
    +    go units rest (x : xs)           = go units (x : rest) xs
    162 
    +    go units rest []                 = (reverse units, reverse rest)

    • —
    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/85ec1752a307b199cfecc40e63fe2e0b5b1affe9 at 1784719092