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

Commits:

21 changed files:

Changes:

  • changelog.d/unit-index
    1 
    +section: compiler
    2 
    +synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units
    3 
    +issues: #27500 #26423
    4 
    +mrs: !16115
    5 
    +
    6 
    +description: {
    7 
    +    The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s.
    8 
    +    This can lead to excessive memory usage with multiple home units and large package databases.
    9 
    +
    10 
    +    Our solution to this problem is deduplicating ``UnitInfo``s globally across the whole ``UnitEnv``.
    11 
    +    We store this information in the ``UnitIndex`` which contains data global to all ``UnitState``s.
    12 
    +    All processed ``UnitInfo``s and the ``WiredMap`` are stored in there, and in the future, we might
    13 
    +    move more fields from ``UnitState`` to ``UnitIndex``.
    14 
    +}

  • compiler/GHC/Unit/External/Database.hs
    ... ... @@ -14,18 +14,52 @@ module GHC.Unit.External.Database (
    14 14 
       lookupExternalUnitDatabases,
    15 15 
       -- *
    16 16 
       UnitDatabase (..),
    17 
    +  -- *
    18 
    +  mergeDatabases,
    19 
    +  UnitPrecedenceMap,
    20 
    +  sortByPreference,
    21 
    +  compareByPreference,
    22 
    +  -- *
    23 
    +  UnitDbConfig(..),
    24 
    +  readOrGetUnitDatabase,
    25 
    +  readUnitDatabases,
    26 
    +  readUnitDatabase,
    27 
    +  getUnitDbRefs,
    28 
    +  resolveUnitDatabase,
    17 29 
     ) where
    18 30
    19 31 
     import GHC.Prelude
    20 32
    21 
    -import GHC.Data.OsPath
    22 
    -import GHC.Unit.Info
    23 
    -import GHC.Utils.Outputable
    33 
    +import GHC.Driver.DynFlags
    24 34
    25 
    -import Data.IORef (IORef)
    35 
    +import Control.Monad
    36 
    +import Data.Char
    37 
    +import Data.IORef
    26 38 
     import Data.IORef qualified as IORef
    27 
    -import Data.Map.Strict
    39 
    +import Data.List (partition, sortBy)
    40 
    +import Data.Map.Strict (Map)
    28 41 
     import Data.Map.Strict qualified as Map
    42 
    +import Data.Ord
    43 
    +import Data.Set (Set)
    44 
    +import Data.Set qualified as Set
    45 
    +import GHC.Data.Maybe
    46 
    +import GHC.Data.OsPath (OsPath)
    47 
    +import GHC.Data.OsPath qualified as OsPath
    48 
    +import GHC.Data.ShortText qualified as ST
    49 
    +import GHC.Platform.ArchOS
    50 
    +import GHC.Types.Unique.Map
    51 
    +import GHC.Unit.Database
    52 
    +import GHC.Unit.Info
    53 
    +import GHC.Unit.Types
    54 
    +import GHC.Utils.Error
    55 
    +import GHC.Utils.Exception
    56 
    +import GHC.Utils.Logger
    57 
    +import GHC.Utils.Misc
    58 
    +import GHC.Utils.Outputable as Outputable
    59 
    +import GHC.Utils.Panic
    60 
    +import System.Directory
    61 
    +import System.Environment (getEnv)
    62 
    +import System.FilePath as FilePath
    29 63
    30 64 
     -- ----------------------------------------------------------------------------
    31 65 
     -- ExternalUnitDatabaseCache
    ... ... @@ -102,3 +136,274 @@ data UnitDatabase unit = UnitDatabase
    102 136
    103 137 
     instance (Outputable u) => Outputable (UnitDatabase u) where
    104 138 
       ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp
    139 
    +
    140 
    +-- ----------------------------------------------------------------------------
    141 
    +--
    142 
    +-- Merging databases
    143 
    +--
    144 
    +
    145 
    +-- | For each unit, a mapping from uid -> i indicates that this
    146 
    +-- unit was brought into GHC by the ith @-package-db@ flag on
    147 
    +-- the command line.  We use this mapping to make sure we prefer
    148 
    +-- units that were defined later on the command line, if there
    149 
    +-- is an ambiguity.
    150 
    +type UnitPrecedenceMap = UniqMap UnitId Int
    151 
    +
    152 
    +-- | Given a list of databases, merge them together, where
    153 
    +-- units with the same unit id in later databases override
    154 
    +-- earlier ones.  This does NOT check if the resulting database
    155 
    +-- makes sense (that's done by 'validateDatabase').
    156 
    +mergeDatabases :: Logger -> [UnitDatabase UnitId]
    157 
    +               -> IO (UnitInfoMap, UnitPrecedenceMap)
    158 
    +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
    159 
    +  where
    160 
    +    merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
    161 
    +      debugTraceMsg logger 2 $
    162 
    +          text "loading package database" <+> ppr db_path
    163 
    +      when (logVerbAtLeast logger 2) $
    164 
    +        forM_ (Set.toList override_set) $ \pkg ->
    165 
    +            debugTraceMsg logger 2 $
    166 
    +                text "package" <+> ppr pkg <+>
    167 
    +                text "overrides a previously defined package"
    168 
    +      return (pkg_map', prec_map')
    169 
    +     where
    170 
    +      db_map = mk_pkg_map db
    171 
    +      mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p))
    172 
    +
    173 
    +      -- The set of UnitIds which appear in both db and pkgs.  These are the
    174 
    +      -- ones that get overridden.  Compute this just to give some
    175 
    +      -- helpful debug messages at -v2
    176 
    +      override_set :: Set UnitId
    177 
    +      override_set = Set.intersection (nonDetUniqMapToKeySet db_map)
    178 
    +                                      (nonDetUniqMapToKeySet pkg_map)
    179 
    +
    180 
    +      -- Now merge the sets together (NB: in case of duplicate,
    181 
    +      -- first argument preferred)
    182 
    +      pkg_map' :: UnitInfoMap
    183 
    +      pkg_map' = pkg_map `plusUniqMap` db_map
    184 
    +
    185 
    +      prec_map' :: UnitPrecedenceMap
    186 
    +      prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map)
    187 
    +
    188 
    +-- | This sorts a list of packages, putting "preferred" packages first.
    189 
    +-- See 'compareByPreference' for the semantics of "preference".
    190 
    +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
    191 
    +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))
    192 
    +
    193 
    +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
    194 
    +-- which should be "active".  Here is the order of preference:
    195 
    +--
    196 
    +--      1. First, prefer the latest version
    197 
    +--      2. If the versions are the same, prefer the package that
    198 
    +--      came in the latest package database.
    199 
    +--
    200 
    +-- Pursuant to #12518, we could change this policy to, for example, remove
    201 
    +-- the version preference, meaning that we would always prefer the units
    202 
    +-- in later unit database.
    203 
    +compareByPreference
    204 
    +    :: UnitPrecedenceMap
    205 
    +    -> UnitInfo
    206 
    +    -> UnitInfo
    207 
    +    -> Ordering
    208 
    +compareByPreference prec_map pkg pkg'
    209 
    +  = case comparing unitPackageVersion pkg pkg' of
    210 
    +        GT -> GT
    211 
    +        EQ | Just prec  <- lookupUniqMap prec_map (unitId pkg)
    212 
    +           , Just prec' <- lookupUniqMap prec_map (unitId pkg')
    213 
    +           -- Prefer the unit from the later DB flag (i.e., higher
    214 
    +           -- precedence)
    215 
    +           -> compare prec prec'
    216 
    +           | otherwise
    217 
    +           -> EQ
    218 
    +        LT -> LT
    219 
    +
    220 
    +-- -----------------------------------------------------------------------------
    221 
    +-- Reading the unit database(s)
    222 
    +
    223 
    +data UnitDbConfig = UnitDbConfig
    224 
    +  { unitDbConfigFlagsDB :: [PackageDBFlag]
    225 
    +  , unitDbConfigProgramName :: String
    226 
    +  , unitDbConfigDBName :: FilePath
    227 
    +  , unitDbConfigPlatformArchOS :: ArchOS
    228 
    +  , unitDbConfigGlobalDB :: FilePath
    229 
    +  , unitDbConfigGHCDir :: FilePath
    230 
    +  , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId
    231 
    +  }
    232 
    +
    233 
    +readUnitDatabases :: Logger -> UnitDbConfig -> IO [UnitDatabase UnitId]
    234 
    +readUnitDatabases logger cfg = do
    235 
    +  conf_refs <- getUnitDbRefs cfg
    236 
    +  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
    237 
    +  mapM (readOrGetUnitDatabase logger cfg) confs
    238 
    +
    239 
    +
    240 
    +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]
    241 
    +getUnitDbRefs cfg = do
    242 
    +  let system_conf_refs = [UserPkgDb, GlobalPkgDb]
    243 
    +
    244 
    +  e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH")
    245 
    +  let base_conf_refs = case e_pkg_path of
    246 
    +        Left _ -> system_conf_refs
    247 
    +        Right path
    248 
    +         | Just (xs, x) <- snocView path, isSearchPathSeparator x
    249 
    +         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs
    250 
    +         | otherwise
    251 
    +         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))
    252 
    +
    253 
    +  -- Apply the package DB-related flags from the command line to get the
    254 
    +  -- final list of package DBs.
    255 
    +  --
    256 
    +  -- Notes on ordering:
    257 
    +  --  * The list of flags is reversed (later ones first)
    258 
    +  --  * We work with the package DB list in "left shadows right" order
    259 
    +  --  * and finally reverse it at the end, to get "right shadows left"
    260 
    +  --
    261 
    +  return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg))
    262 
    + where
    263 
    +  doFlag (PackageDB p) dbs = p : dbs
    264 
    +  doFlag NoUserPackageDB dbs = filter isNotUser dbs
    265 
    +  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
    266 
    +  doFlag ClearPackageDBs _ = []
    267 
    +
    268 
    +  isNotUser UserPkgDb = False
    269 
    +  isNotUser _ = True
    270 
    +
    271 
    +  isNotGlobal GlobalPkgDb = False
    272 
    +  isNotGlobal _ = True
    273 
    +
    274 
    +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'
    275 
    +-- when the user database filepath is expected but the latter doesn't exist.
    276 
    +--
    277 
    +-- NB: This logic is reimplemented in Cabal, so if you change it,
    278 
    +-- make sure you update Cabal. (Or, better yet, dump it in the
    279 
    +-- compiler info so Cabal can use the info.)
    280 
    +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath)
    281 
    +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg
    282 
    +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
    283 
    +  dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg)
    284 
    +  let pkgconf = dir </> unitDbConfigDBName cfg
    285 
    +  exist <- tryMaybeT $ doesDirectoryExist pkgconf
    286 
    +  if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
    287 
    +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
    288 
    +
    289 
    +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
    290 
    +readOrGetUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
    291 
    +readOrGetUnitDatabase logger cfg conf_file =
    292 
    +  readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case
    293 
    +    Nothing -> do
    294 
    +      new_db <- readUnitDatabase logger cfg conf_file
    295 
    +      cacheExternalUnitDatabase (unitDbConfigDBCache cfg) new_db
    296 
    +      pure new_db
    297 
    +    Just db ->
    298 
    +      pure db
    299 
    +
    300 
    +-- | Read the 'UnitDatabase' at the given location.
    301 
    +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
    302 
    +readUnitDatabase logger cfg conf_file = do
    303 
    +  isdir <- OsPath.doesDirectoryExist conf_file
    304 
    +
    305 
    +  proto_pkg_configs <-
    306 
    +    if isdir
    307 
    +       then readDirStyleUnitInfo conf_file
    308 
    +       else do
    309 
    +            isfile <- OsPath.doesFileExist conf_file
    310 
    +            if isfile
    311 
    +               then do
    312 
    +                 mpkgs <- tryReadOldFileStyleUnitInfo
    313 
    +                 case mpkgs of
    314 
    +                   Just pkgs -> return pkgs
    315 
    +                   Nothing   -> throwGhcExceptionIO $ InstallationError $
    316 
    +                      "ghc no longer supports single-file style package " ++
    317 
    +                      "databases (" ++ show conf_file ++
    318 
    +                      ") use 'ghc-pkg init' to create the database with " ++
    319 
    +                      "the correct format."
    320 
    +               else throwGhcExceptionIO $ InstallationError $
    321 
    +                      "can't find a package database at " ++ show conf_file
    322 
    +
    323 
    +  let
    324 
    +      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
    325 
    +      conf_file' = OsPath.dropTrailingPathSeparator conf_file
    326 
    +      top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg)
    327 
    +      pkgroot = OsPath.takeDirectory conf_file'
    328 
    +      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
    329 
    +                         proto_pkg_configs
    330 
    +  --
    331 
    +  pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1
    332 
    +  return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2
    333 
    +  where
    334 
    +    readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
    335 
    +    readDirStyleUnitInfo conf_dir = do
    336 
    +      let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache")
    337 
    +      cache_exists <- OsPath.doesFileExist filename
    338 
    +      if cache_exists
    339 
    +        then do
    340 
    +          debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename
    341 
    +          readPackageDbForGhc filename
    342 
    +        else do
    343 
    +          -- If there is no package.cache file, we check if the database is not
    344 
    +          -- empty by inspecting if the directory contains any .conf file. If it
    345 
    +          -- does, something is wrong and we fail. Otherwise we assume that the
    346 
    +          -- database is empty.
    347 
    +          debugTraceMsg logger 2 $ text "There is no package.cache in"
    348 
    +                      <+> ppr conf_dir
    349 
    +                       <> text ", checking if the database is empty"
    350 
    +          db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))
    351 
    +                   <$> OsPath.getDirectoryContents conf_dir
    352 
    +          if db_empty
    353 
    +            then do
    354 
    +              debugTraceMsg logger 3 $ text "There are no .conf files in"
    355 
    +                          <+> ppr conf_dir <> text ", treating"
    356 
    +                          <+> text "package database as empty"
    357 
    +              return []
    358 
    +            else
    359 
    +              throwGhcExceptionIO $ InstallationError $
    360 
    +                "there is no package.cache in " ++ show conf_dir ++
    361 
    +                " even though package database is not empty"
    362 
    +
    363 
    +
    364 
    +    -- Single-file style package dbs have been deprecated for some time, but
    365 
    +    -- it turns out that Cabal was using them in one place. So this is a
    366 
    +    -- workaround to allow older Cabal versions to use this newer ghc.
    367 
    +    -- We check if the file db contains just "[]" and if so, we look for a new
    368 
    +    -- dir-style db in conf_file.d/, ie in a dir next to the given file.
    369 
    +    -- We cannot just replace the file with a new dir style since Cabal still
    370 
    +    -- assumes it's a file and tries to overwrite with 'writeFile'.
    371 
    +    -- ghc-pkg also cooperates with this workaround.
    372 
    +    tryReadOldFileStyleUnitInfo = do
    373 
    +      content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""
    374 
    +      if take 2 content == "[]"
    375 
    +        then do
    376 
    +          let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"
    377 
    +          direxists <- OsPath.doesDirectoryExist conf_dir
    378 
    +          if direxists
    379 
    +             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir)
    380 
    +                     liftM Just (readDirStyleUnitInfo conf_dir)
    381 
    +             else return (Just []) -- ghc-pkg will create it when it's updated
    382 
    +        else return Nothing
    383 
    +
    384 
    +mungeUnitInfo :: OsPath -> OsPath
    385 
    +                   -> UnitInfo -> UnitInfo
    386 
    +mungeUnitInfo top_dir pkgroot =
    387 
    +    mungeBytecodeLibFields
    388 
    +  . mungeLibDirFields
    389 
    +  . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))
    390 
    +
    391 
    +mungeLibDirFields :: UnitInfo -> UnitInfo
    392 
    +mungeLibDirFields pkg =
    393 
    +    pkg {
    394 
    +      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
    395 
    +         [] -> unitLibraryDirs pkg
    396 
    +         ds -> ds
    397 
    +      , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of
    398 
    +         [] -> unitLibraryDirs pkg
    399 
    +         ds -> ds
    400 
    +    }
    401 
    +
    402 
    +-- | Default to using library-dirs if bytecode library dirs is not explicitly set.
    403 
    +mungeBytecodeLibFields :: UnitInfo -> UnitInfo
    404 
    +mungeBytecodeLibFields pkg =
    405 
    +    pkg {
    406 
    +      unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of
    407 
    +         [] -> unitLibraryDirs pkg
    408 
    +         ds -> ds
    409 
    +    }

  • compiler/GHC/Unit/External/Index.hs
    1 
    +module GHC.Unit.External.Index (
    2 
    +  -- *
    3 
    +  UnitIndex,
    4 
    +  initUnitIndex,
    5 
    +  wiringMap,
    6 
    +  unwiringMap,
    7 
    +  globalUnits,
    8 
    +  setWireMap,
    9 
    +  isWireMapEmpty,
    10 
    +  addUnitInfoMap,
    11 
    +
    12 
    +  -- *
    13 
    +  GlobalUnitInfoMap,
    14 
    +  lookupGlobalUnitInfoMap,
    15 
    +  mkGlobalUnitKey,
    16 
    +
    17 
    +  -- *
    18 
    +  GlobalUnitKey,
    19 
    +  globalUnitKeyFromUnitInfo,
    20 
    +
    21 
    +  -- *
    22 
    +  updateWiredInUnits,
    23 
    +  updateWiredInUnitsInUnitInfo,
    24 
    +  upd_wired_in_mod,
    25 
    +  -- *
    26 
    +  unwireUnit,
    27 
    +) where
    28 
    +
    29 
    +import GHC.Prelude
    30 
    +
    31 
    +import GHC.Data.ShortText qualified as ST
    32 
    +import GHC.Types.Unique.Map
    33 
    +import GHC.Unit.Database
    34 
    +import GHC.Unit.External.Wired
    35 
    +import GHC.Unit.Info
    36 
    +import GHC.Unit.Types
    37 
    +
    38 
    +import Data.Map.Strict (Map)
    39 
    +import Data.Map.Strict qualified as Map
    40 
    +import GHC.Utils.Outputable
    41 
    +
    42 
    +-- ----------------------------------------------------------------------------
    43 
    +-- UnitIndex
    44 
    +-- ----------------------------------------------------------------------------
    45 
    +
    46 
    +data UnitIndex = UnitIndex
    47 
    +  { ui_wireMap :: !WiringMap
    48 
    +    -- ^ A mapping from database unit keys to wired in unit ids.
    49 
    +  , ui_unwireMap :: !UnwiringMap
    50 
    +    -- ^ A mapping from wired in unit ids to unit keys from the database.
    51 
    +  , ui_unitInfoMap :: !GlobalUnitInfoMap
    52 
    +    -- ^ TODO @fendor: document
    53 
    +  }
    54 
    +
    55 
    +wiringMap :: UnitIndex -> UnwiringMap
    56 
    +wiringMap = ui_wireMap
    57 
    +
    58 
    +unwiringMap :: UnitIndex -> WiringMap
    59 
    +unwiringMap = ui_unwireMap
    60 
    +
    61 
    +globalUnits :: UnitIndex -> GlobalUnitInfoMap
    62 
    +globalUnits = ui_unitInfoMap
    63 
    +
    64 
    +initUnitIndex :: UnitIndex
    65 
    +initUnitIndex = UnitIndex
    66 
    +  { ui_wireMap = emptyUniqMap
    67 
    +  , ui_unwireMap = emptyUniqMap
    68 
    +  , ui_unitInfoMap = emptyUniqMap
    69 
    +  }
    70 
    +
    71 
    +setWireMap :: WiringMap -> UnitIndex -> UnitIndex
    72 
    +setWireMap wired_map unit_index =
    73 
    +  unit_index
    74 
    +    { ui_wireMap = wired_map
    75 
    +    , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    76 
    +    }
    77 
    +
    78 
    +isWireMapEmpty :: UnitIndex -> Bool
    79 
    +isWireMapEmpty unit_index =
    80 
    +  isNullUniqMap (ui_wireMap unit_index)
    81 
    +
    82 
    +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex
    83 
    +addUnitInfoMap unit_info_map unit_index =
    84 
    +  unit_index
    85 
    +    { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index)
    86 
    +    }
    87 
    +  where
    88 
    +    globalMap :: GlobalUnitInfoMap
    89 
    +    globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map
    90 
    +
    91 
    +-- ----------------------------------------------------------------------------
    92 
    +-- GlobalUnitInfoMap
    93 
    +-- ----------------------------------------------------------------------------
    94 
    +
    95 
    +type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo)
    96 
    +
    97 
    +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo
    98 
    +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap =
    99 
    +  case lookupUniqMap globalMap uid of
    100 
    +    Nothing -> Nothing
    101 
    +    Just sameUnitId -> Map.lookup abiHash sameUnitId
    102 
    +
    103 
    +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap
    104 
    +mkGlobalUnitInfoMap unitInfos =
    105 
    +  listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos
    106 
    +
    107 
    +-- ----------------------------------------------------------------------------
    108 
    +-- GlobalUnitKey
    109 
    +-- ----------------------------------------------------------------------------
    110 
    +
    111 
    +data GlobalUnitKey =
    112 
    +  GlobalUnitKey
    113 
    +    !UnitId -- ^ Unit Id of the 'UnitInfo'
    114 
    +    !ST.ShortText
    115 
    +
    116 
    +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey
    117 
    +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui)
    118 
    +
    119 
    +mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey
    120 
    +mkGlobalUnitKey = GlobalUnitKey
    121 
    +
    122 
    +-- -----------------------------------------------------------------------------
    123 
    +-- Wired-in units
    124 
    +--
    125 
    +-- See Note [Wired-in units] in GHC.Unit.Types
    126 
    +
    127 
    +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
    128 
    +-- that it was recorded as in the package database.
    129 
    +unwireUnit :: UnitIndex -> Unit -> Unit
    130 
    +unwireUnit state uid@(RealUnit (Definite def_uid)) =
    131 
    +    maybe uid (RealUnit . Definite) (lookupUniqMap (unwiringMap state) def_uid)
    132 
    +unwireUnit _ uid = uid
    133 
    +
    134 
    +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
    135 
    +updateWiredInUnits wiredInMap knownInfos pkgs =
    136 
    +  map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs
    137 
    +
    138 
    +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
    139 
    +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg =
    140 
    +  let
    141 
    +    upd_wired_in_pkg wiredInUnitId pkg =
    142 
    +      pkg { unitId         = wiredInUnitId
    143 
    +          , unitInstanceOf = wiredInUnitId
    144 
    +              -- every non instantiated unit is an instance of
    145 
    +              -- itself (required by Backpack...)
    146 
    +              --
    147 
    +              -- See Note [About units] in GHC.Unit
    148 
    +          }
    149 
    +
    150 
    +    upd_deps pkg = pkg {
    151 
    +          unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
    152 
    +          unitExposedModules
    153 
    +            = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
    154 
    +                  (unitExposedModules pkg)
    155 
    +        }
    156 
    +  in
    157 
    +    case lookupUniqMap wiredInMap (unitId pkg) of
    158 
    +      Just wiredIn ->
    159 
    +        case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of
    160 
    +          Just ui ->
    161 
    +            Right ui
    162 
    +          Nothing ->
    163 
    +            let
    164 
    +              updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg
    165 
    +            in
    166 
    +              Left $ seqUnitInfo updated_pkg updated_pkg
    167 
    +      Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of
    168 
    +        Just ui ->
    169 
    +          Right ui
    170 
    +        Nothing ->
    171 
    +          let
    172 
    +            updated_pkg = upd_deps pkg
    173 
    +          in
    174 
    +            Left $ seqUnitInfo updated_pkg updated_pkg
    175 
    +
    176 
    +-- Helper functions for rewiring Module and Unit.  These
    177 
    +-- rewrite Units of modules in wired-in packages to the form known to the
    178 
    +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types.
    179 
    +--
    180 
    +-- For instance, base-4.9.0.0 will be rewritten to just base, to match
    181 
    +-- what appears in GHC.Builtin.Names.
    182 
    +
    183 
    +upd_wired_in_mod :: WiringMap -> Module -> Module
    184 
    +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
    185 
    +
    186 
    +upd_wired_in_uid :: WiringMap -> Unit -> Unit
    187 
    +upd_wired_in_uid wiredInMap u = case u of
    188 
    +   HoleUnit -> HoleUnit
    189 
    +   RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))
    190 
    +   VirtUnit indef_uid ->
    191 
    +      VirtUnit $ mkInstantiatedUnit
    192 
    +        (instUnitInstanceOf indef_uid)
    193 
    +        (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid))
    194 
    +
    195 
    +upd_wired_in :: WiringMap -> UnitId -> UnitId
    196 
    +upd_wired_in wiredInMap key
    197 
    +    | Just key' <- lookupUniqMap wiredInMap key = key'
    198 
    +    | otherwise = key

  • compiler/GHC/Unit/External/ModuleOrigin.hs
    1 
    +module GHC.Unit.External.ModuleOrigin (
    2 
    +  ModuleOrigin(..),
    3 
    +  fromExposedModules,
    4 
    +  fromReexportedModules,
    5 
    +  fromFlag,
    6 
    +  originVisible,
    7 
    +  originEmpty,
    8 
    +) where
    9 
    +
    10 
    +import GHC.Prelude
    11 
    +import GHC.Unit.External.Validate
    12 
    +import GHC.Unit.Info
    13 
    +import GHC.Utils.Outputable
    14 
    +import GHC.Utils.Panic
    15 
    +import qualified Data.Semigroup as Semigroup
    16 
    +
    17 
    +-- | Given a module name, there may be multiple ways it came into scope,
    18 
    +-- possibly simultaneously.  This data type tracks all the possible ways
    19 
    +-- it could have come into scope.  Warning: don't use the record functions,
    20 
    +-- they're partial!
    21 
    +data ModuleOrigin =
    22 
    +    -- | Module is hidden, and thus never will be available for import.
    23 
    +    -- (But maybe the user didn't realize), so we'll still keep track
    24 
    +    -- of these modules.)
    25 
    +    ModHidden
    26 
    +
    27 
    +    -- | Module is unavailable because the unit is unusable.
    28 
    +  | ModUnusable !UnusableUnit
    29 
    +
    30 
    +    -- | Module is public, and could have come from some places.
    31 
    +  | ModOrigin {
    32 
    +        -- | @Just False@ means that this module is in
    33 
    +        -- someone's @exported-modules@ list, but that package is hidden;
    34 
    +        -- @Just True@ means that it is available; @Nothing@ means neither
    35 
    +        -- applies.
    36 
    +        fromOrigUnit :: Maybe Bool
    37 
    +        -- | Is the module available from a reexport of an exposed package?
    38 
    +        -- There could be multiple.
    39 
    +      , fromExposedReexport :: [UnitInfo]
    40 
    +        -- | Is the module available from a reexport of a hidden package?
    41 
    +      , fromHiddenReexport :: [UnitInfo]
    42 
    +        -- | Did the module export come from a package flag? (ToDo: track
    43 
    +        -- more information.
    44 
    +      , fromPackageFlag :: Bool
    45 
    +      }
    46 
    +
    47 
    +instance Outputable ModuleOrigin where
    48 
    +    ppr ModHidden = text "hidden module"
    49 
    +    ppr (ModUnusable _) = text "unusable module"
    50 
    +    ppr (ModOrigin e res rhs f) = sep (punctuate comma (
    51 
    +        (case e of
    52 
    +            Nothing -> []
    53 
    +            Just False -> [text "hidden package"]
    54 
    +            Just True -> [text "exposed package"]) ++
    55 
    +        (if null res
    56 
    +            then []
    57 
    +            else [text "reexport by" <+>
    58 
    +                    sep (map (ppr . mkUnit) res)]) ++
    59 
    +        (if null rhs
    60 
    +            then []
    61 
    +            else [text "hidden reexport by" <+>
    62 
    +                    sep (map (ppr . mkUnit) rhs)]) ++
    63 
    +        (if f then [text "package flag"] else [])
    64 
    +        ))
    65 
    +
    66 
    +-- | Smart constructor for a module which is in @exposed-modules@.  Takes
    67 
    +-- as an argument whether or not the defining package is exposed.
    68 
    +fromExposedModules :: Bool -> ModuleOrigin
    69 
    +fromExposedModules e = ModOrigin (Just e) [] [] False
    70 
    +
    71 
    +-- | Smart constructor for a module which is in @reexported-modules@.  Takes
    72 
    +-- as an argument whether or not the reexporting package is exposed, and
    73 
    +-- also its 'UnitInfo'.
    74 
    +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
    75 
    +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
    76 
    +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
    77 
    +
    78 
    +-- | Smart constructor for a module which was bound by a package flag.
    79 
    +fromFlag :: ModuleOrigin
    80 
    +fromFlag = ModOrigin Nothing [] [] True
    81 
    +
    82 
    +instance Semigroup ModuleOrigin where
    83 
    +    x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') =
    84 
    +        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
    85 
    +      where g (Just b) (Just b')
    86 
    +                | b == b'   = Just b
    87 
    +                | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $
    88 
    +                    text "x: " <> ppr x $$ text "y: " <> ppr y
    89 
    +            g Nothing x = x
    90 
    +            g x Nothing = x
    91 
    +
    92 
    +    x <> y = pprPanic "ModOrigin: module origin mismatch" $
    93 
    +                 text "x: " <> ppr x $$ text "y: " <> ppr y
    94 
    +
    95 
    +instance Monoid ModuleOrigin where
    96 
    +    mempty = ModOrigin Nothing [] [] False
    97 
    +    mappend = (Semigroup.<>)
    98 
    +
    99 
    +-- | Is the name from the import actually visible? (i.e. does it cause
    100 
    +-- ambiguity, or is it only relevant when we're making suggestions?)
    101 
    +originVisible :: ModuleOrigin -> Bool
    102 
    +originVisible ModHidden = False
    103 
    +originVisible (ModUnusable _) = False
    104 
    +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
    105 
    +
    106 
    +-- | Are there actually no providers for this module?  This will never occur
    107 
    +-- except when we're filtering based on package imports.
    108 
    +originEmpty :: ModuleOrigin -> Bool
    109 
    +originEmpty (ModOrigin Nothing [] [] False) = True
    110 
    +originEmpty _ = False

  • compiler/GHC/Unit/External/Providers.hs
    1 
    +module GHC.Unit.External.Providers (
    2 
    +  ModuleNameProvidersMap,
    3 
    +  pprModuleMap,
    4 
    +  mkModuleNameProvidersMap,
    5 
    +  mkUnusableModuleNameProvidersMap,
    6 
    +) where
    7 
    +
    8 
    +import GHC.Prelude
    9 
    +
    10 
    +import GHC.Data.Maybe
    11 
    +import GHC.Types.Unique
    12 
    +import GHC.Types.Unique.FM
    13 
    +import GHC.Types.Unique.Map
    14 
    +import GHC.Unit.External.ModuleOrigin
    15 
    +import GHC.Unit.External.Query
    16 
    +import GHC.Unit.External.Validate
    17 
    +import GHC.Unit.External.Visibility
    18 
    +import GHC.Unit.Info
    19 
    +import GHC.Unit.Module
    20 
    +import GHC.Utils.Error
    21 
    +import GHC.Utils.Logger
    22 
    +import GHC.Utils.Outputable
    23 
    +import GHC.Utils.Panic
    24 
    +
    25 
    +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and
    26 
    +-- its 'ModuleOrigin').
    27 
    +--
    28 
    +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
    29 
    +-- origin for a given 'Module'
    30 
    +
    31 
    +type ModuleNameProvidersMap =
    32 
    +    UniqMap ModuleName (UniqMap Module ModuleOrigin)
    33 
    +
    34 
    +-- | Show the mapping of modules to where they come from.
    35 
    +pprModuleMap :: ModuleNameProvidersMap -> SDoc
    36 
    +pprModuleMap mod_map =
    37 
    +  vcat (map pprLine (nonDetUniqMapToList mod_map))
    38 
    +    where
    39 
    +      pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e)))
    40 
    +      pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
    41 
    +      pprEntry m (m',o)
    42 
    +        | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o)
    43 
    +        | otherwise = ppr m' <+> parens (ppr o)
    44 
    +
    45 
    +-- -----------------------------------------------------------------------------
    46 
    +-- | Makes the mapping from ModuleName to package info
    47 
    +
    48 
    +-- Slight irritation: we proceed by leafing through everything
    49 
    +-- in the installed package database, which makes handling indefinite
    50 
    +-- packages a bit bothersome.
    51 
    +
    52 
    +mkModuleNameProvidersMap
    53 
    +  :: Logger
    54 
    +  -> Bool
    55 
    +  -> UnitInfoMap
    56 
    +  -> VisibilityMap
    57 
    +  -> ModuleNameProvidersMap
    58 
    +mkModuleNameProvidersMap logger allowVirtualUnits pkg_map vis_map =
    59 
    +    -- What should we fold on?  Both situations are awkward:
    60 
    +    --
    61 
    +    --    * Folding on the visibility map means that we won't create
    62 
    +    --      entries for packages that aren't mentioned in vis_map
    63 
    +    --      (e.g., hidden packages, causing #14717)
    64 
    +    --
    65 
    +    --    * Folding on pkg_map is awkward because if we have an
    66 
    +    --      Backpack instantiation, we need to possibly add a
    67 
    +    --      package from pkg_map multiple times to the actual
    68 
    +    --      ModuleNameProvidersMap.  Also, we don't really want
    69 
    +    --      definite package instantiations to show up in the
    70 
    +    --      list of possibilities.
    71 
    +    --
    72 
    +    -- So what will we do instead?  We'll extend vis_map with
    73 
    +    -- entries for every definite (for non-Backpack) and
    74 
    +    -- indefinite (for Backpack) package, so that we get the
    75 
    +    -- hidden entries we need.
    76 
    +    nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended
    77 
    + where
    78 
    +  vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map
    79 
    +
    80 
    +  default_vis = listToUniqMap
    81 
    +                  [ (mkUnit pkg, mempty)
    82 
    +                  | (_, pkg) <- nonDetUniqMapToList pkg_map
    83 
    +                  -- Exclude specific instantiations of an indefinite
    84 
    +                  -- package
    85 
    +                  , unitIsIndefinite pkg || null (unitInstantiations pkg)
    86 
    +                  ]
    87 
    +
    88 
    +  emptyMap = emptyUniqMap
    89 
    +  setOrigins m os = fmap (const os) m
    90 
    +  extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap
    91 
    +    = addListTo modmap theBindings
    92 
    +   where
    93 
    +    pkg = unit_lookup uid
    94 
    +
    95 
    +    theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
    96 
    +    theBindings = newBindings b rns
    97 
    +
    98 
    +    newBindings :: Bool
    99 
    +                -> [(ModuleName, ModuleName)]
    100 
    +                -> [(ModuleName, UniqMap Module ModuleOrigin)]
    101 
    +    newBindings e rns  = es e ++ hiddens ++ map rnBinding rns
    102 
    +
    103 
    +    rnBinding :: (ModuleName, ModuleName)
    104 
    +              -> (ModuleName, UniqMap Module ModuleOrigin)
    105 
    +    rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
    106 
    +     where origEntry = case lookupUFM esmap orig of
    107 
    +            Just r -> r
    108 
    +            Nothing -> throwGhcException (CmdLineError (renderWithContext
    109 
    +                        (log_default_user_context (logFlags logger))
    110 
    +                        (text "package flag: could not find module name" <+>
    111 
    +                            ppr orig <+> text "in package" <+> ppr pk)))
    112 
    +
    113 
    +    es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
    114 
    +    es e = do
    115 
    +     (m, exposedReexport) <- exposed_mods
    116 
    +     let (pk', m', origin') =
    117 
    +          case exposedReexport of
    118 
    +           Nothing -> (pk, m, fromExposedModules e)
    119 
    +           Just (Module pk' m') ->
    120 
    +              (pk', m', fromReexportedModules e pkg)
    121 
    +     return (m, mkModMap pk' m' origin')
    122 
    +
    123 
    +    esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin)
    124 
    +    esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
    125 
    +                                 -- be overwritten
    126 
    +
    127 
    +    hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
    128 
    +
    129 
    +    pk = mkUnit pkg
    130 
    +    unit_lookup uid = lookupUnit' allowVirtualUnits pkg_map uid
    131 
    +                        `orElse` pprPanic "unit_lookup" (ppr uid)
    132 
    +
    133 
    +    exposed_mods = unitExposedModules pkg
    134 
    +    hidden_mods  = unitHiddenModules pkg
    135 
    +
    136 
    +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages.
    137 
    +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
    138 
    +mkUnusableModuleNameProvidersMap unusables =
    139 
    +    nonDetFoldUniqMap extend_modmap emptyUniqMap unusables
    140 
    + where
    141 
    +    extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings
    142 
    +      where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
    143 
    +            bindings = exposed ++ hidden
    144 
    +
    145 
    +            origin_reexport =  ModUnusable (UnusableUnit unit reason True)
    146 
    +            origin_normal   =  ModUnusable (UnusableUnit unit reason False)
    147 
    +            unit = mkUnit unit_info
    148 
    +
    149 
    +            exposed = map get_exposed exposed_mods
    150 
    +            hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods]
    151 
    +
    152 
    +            -- with re-exports, c:Foo can be reexported from two (or more)
    153 
    +            -- unusable packages:
    154 
    +            --  Foo -> a:Foo (unusable reason A) -> c:Foo
    155 
    +            --      -> b:Foo (unusable reason B) -> c:Foo
    156 
    +            --
    157 
    +            -- We must be careful to not record the following (#21097):
    158 
    +            --  Foo -> c:Foo (unusable reason A)
    159 
    +            --      -> c:Foo (unusable reason B)
    160 
    +            -- But:
    161 
    +            --  Foo -> a:Foo (unusable reason A)
    162 
    +            --      -> b:Foo (unusable reason B)
    163 
    +            --
    164 
    +            get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport)
    165 
    +            get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal)
    166 
    +              -- in the reexport case, we create a virtual module that doesn't
    167 
    +              -- exist but we don't care as it's only used as a key in the map.
    168 
    +
    169 
    +            exposed_mods = unitExposedModules unit_info
    170 
    +            hidden_mods  = unitHiddenModules  unit_info
    171 
    +
    172 
    +-- | Add a list of key/value pairs to a nested map.
    173 
    +--
    174 
    +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
    175 
    +-- when reloading modules in GHCi (see #4029). This ensures that each
    176 
    +-- value is forced before installing into the map.
    177 
    +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2)
    178 
    +          => UniqMap k1 (UniqMap k2 a)
    179 
    +          -> [(k1, UniqMap k2 a)]
    180 
    +          -> UniqMap k1 (UniqMap k2 a)
    181 
    +addListTo = foldl' merge
    182 
    +  where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v
    183 
    +
    184 
    +-- | Create a singleton module mapping
    185 
    +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
    186 
    +mkModMap pkg mod = unitUniqMap (mkModule pkg mod)

  • compiler/GHC/Unit/External/Query.hs
    1 
    +module GHC.Unit.External.Query (
    2 
    +  -- *
    3 
    +  lookupUnit',
    4 
    +  lookupUnitId',
    5 
    +) where
    6 
    +
    7 
    +import GHC.Prelude
    8 
    +
    9 
    +import GHC.Types.Unique.Map
    10 
    +import GHC.Unit.External.Substitution
    11 
    +import GHC.Unit.Info
    12 
    +import GHC.Unit.Module
    13 
    +
    14 
    +-- | A more specialized interface, which doesn't require a 'UnitState' (so it
    15 
    +-- can be used while we're initializing 'DynFlags')
    16 
    +--
    17 
    +-- Parameters:
    18 
    +--    * a boolean specifying whether or not to look for on-the-fly renamed interfaces
    19 
    +--    * a 'UnitInfoMap'
    20 
    +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo
    21 
    +lookupUnit' allowOnTheFlyInst pkg_map u = case u of
    22 
    +   HoleUnit   -> error "Hole unit"
    23 
    +   RealUnit i -> lookupUniqMap pkg_map (unDefinite i)
    24 
    +   VirtUnit i
    25 
    +      | allowOnTheFlyInst
    26 
    +      -> -- lookup UnitInfo of the indefinite unit to be instantiated and
    27 
    +         -- instantiate it on-the-fly
    28 
    +         fmap (renameUnitInfo pkg_map (instUnitInsts i))
    29 
    +           (lookupUniqMap pkg_map (instUnitInstanceOf i))
    30 
    +
    31 
    +      | otherwise
    32 
    +      -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
    33 
    +         -- units. Even if they are real, installed units, they can't use the
    34 
    +         -- `RealUnit` constructor (it is reserved for definite units) so we use
    35 
    +         -- the `VirtUnit` constructor.
    36 
    +         lookupUniqMap pkg_map (virtualUnitId i)
    37 
    +
    38 
    +
    39 
    +-- | Find the unit we know about with the given unit id, if any
    40 
    +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
    41 
    +lookupUnitId' db uid = lookupUniqMap db uid

  • compiler/GHC/Unit/External/Substitution.hs
    1 
    +module GHC.Unit.External.Substitution (
    2 
    +  -- *
    3 
    +  ShHoleSubst,
    4 
    +  renameHoleModule',
    5 
    +  renameHoleUnit',
    6 
    +  renameUnitInfo,
    7 
    +) where
    8 
    +
    9 
    +import GHC.Prelude
    10 
    +
    11 
    +import GHC.Unit.Module
    12 
    +import GHC.Unit.Info
    13 
    +import GHC.Types.Unique.FM
    14 
    +import GHC.Types.Unique.DFM
    15 
    +import GHC.Types.Unique.DSet
    16 
    +
    17 
    +-- -----------------------------------------------------------------------------
    18 
    +-- Module renaming
    19 
    +
    20 
    +-- | Substitution on module variables, mapping module names to module
    21 
    +-- identifiers.
    22 
    +type ShHoleSubst = ModuleNameEnv Module
    23 
    +
    24 
    +-- | Rename a 'UnitInfo' according to some module instantiation.
    25 
    +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
    26 
    +renameUnitInfo pkg_map insts conf =
    27 
    +    let hsubst = listToUFM insts
    28 
    +        smod  = renameHoleModule' pkg_map hsubst
    29 
    +        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
    30 
    +    in conf {
    31 
    +        unitInstantiations = new_insts,
    32 
    +        unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
    33 
    +                             (unitExposedModules conf)
    34 
    +    }
    35 
    +
    36 
    +
    37 
    +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap'
    38 
    +-- so it can be used by "GHC.Unit.State".
    39 
    +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module
    40 
    +renameHoleModule' pkg_map env m
    41 
    +  | not (isHoleModule m) =
    42 
    +        let uid = renameHoleUnit' pkg_map env (moduleUnit m)
    43 
    +        in mkModule uid (moduleName m)
    44 
    +  | Just m' <- lookupUFM env (moduleName m) = m'
    45 
    +  -- NB m = <Blah>, that's what's in scope.
    46 
    +  | otherwise = m
    47 
    +
    48 
    +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap'
    49 
    +-- so it can be used by "GHC.Unit.State".
    50 
    +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit
    51 
    +renameHoleUnit' pkg_map env uid =
    52 
    +    case uid of
    53 
    +      (VirtUnit
    54 
    +        InstantiatedUnit{ instUnitInstanceOf = cid
    55 
    +                        , instUnitInsts      = insts
    56 
    +                        , instUnitHoles      = fh })
    57 
    +          -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)
    58 
    +                then uid
    59 
    +                else mkVirtUnit cid
    60 
    +                          (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)
    61 
    +      _ -> uid

  • compiler/GHC/Unit/External/Validate.hs
    1 
    +module GHC.Unit.External.Validate (
    2 
    +  validateDatabase,
    3 
    +
    4 
    +  findPackages,
    5 
    +  selectPackages,
    6 
    +
    7 
    +  UnusableUnits,
    8 
    +  reportUnusable,
    9 
    +
    10 
    +  UnusableUnit(..),
    11 
    +
    12 
    +  UnusableUnitReason(..),
    13 
    +  pprReason,
    14 
    +
    15 
    +  UnitErr(..),
    16 
    +  mayThrowUnitErr,
    17 
    +  closeUnitDeps,
    18 
    +  closeUnitDeps',
    19 
    +  ignoreUnits,
    20 
    +  pprFlag,
    21 
    +) where
    22 
    +
    23 
    +import GHC.Prelude
    24 
    +
    25 
    +import Control.Monad
    26 
    +import Data.Graph (SCC (..), stronglyConnComp)
    27 
    +import Data.List (partition)
    28 
    +import GHC.Data.Maybe
    29 
    +import GHC.Driver.DynFlags
    30 
    +import GHC.Types.Unique.Map
    31 
    +import GHC.Unit.External.Database
    32 
    +import GHC.Unit.External.Query
    33 
    +import GHC.Unit.External.Substitution
    34 
    +import GHC.Unit.Info
    35 
    +import GHC.Unit.Types
    36 
    +import GHC.Utils.Error
    37 
    +import GHC.Utils.Logger
    38 
    +import GHC.Utils.Outputable
    39 
    +import GHC.Utils.Outputable qualified as Outputable
    40 
    +import GHC.Utils.Panic
    41 
    +
    42 
    +-- -----------------------------------------------------------------------------
    43 
    +-- Database validation
    44 
    +
    45 
    +-- | Validates a database, removing unusable units from it
    46 
    +-- (this includes removing units that the user has explicitly
    47 
    +-- ignored.)  Our general strategy:
    48 
    +--
    49 
    +-- 1. Remove all broken units (dangling dependencies)
    50 
    +-- 2. Remove all units that are cyclic
    51 
    +-- 3. Apply ignore flags
    52 
    +-- 4. Remove all units which have deps with mismatching ABIs
    53 
    +--
    54 
    +validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap
    55 
    +                 -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
    56 
    +validateDatabase flagsIgnored pkg_map1 =
    57 
    +    (pkg_map5, unusable, sccs)
    58 
    +  where
    59 
    +    ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg)
    60 
    +
    61 
    +    -- Compute the reverse dependency index
    62 
    +    index = reverseDeps pkg_map1
    63 
    +
    64 
    +    -- Helper function
    65 
    +    mk_unusable mk_err dep_matcher m uids =
    66 
    +      listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
    67 
    +                    | pkg <- uids
    68 
    +                    ]
    69 
    +
    70 
    +    -- Find broken units
    71 
    +    directly_broken = filter (not . null . depsNotAvailable pkg_map1)
    72 
    +                             (nonDetEltsUniqMap pkg_map1)
    73 
    +    (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1
    74 
    +    unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
    75 
    +
    76 
    +    -- Find recursive units
    77 
    +    sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)
    78 
    +                            | pkg <- nonDetEltsUniqMap pkg_map2 ]
    79 
    +    getCyclicSCC (CyclicSCC vs) = map unitId vs
    80 
    +    getCyclicSCC (AcyclicSCC _) = []
    81 
    +    (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2
    82 
    +    unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
    83 
    +
    84 
    +    -- Apply ignore flags
    85 
    +    directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3)
    86 
    +    (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3
    87 
    +    unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
    88 
    +
    89 
    +    -- Knock out units whose dependencies don't agree with ABI
    90 
    +    -- (i.e., got invalidated due to shadowing)
    91 
    +    directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
    92 
    +                               (nonDetEltsUniqMap pkg_map4)
    93 
    +    (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4
    94 
    +    unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
    95 
    +
    96 
    +    -- combine all unusables. The order is important for shadowing.
    97 
    +    -- plusUniqMapList folds using plusUFM which is right biased (opposite of
    98 
    +    -- Data.Map.union) so the head of the list should be the least preferred
    99 
    +    unusable = plusUniqMapList [ unusable_shadowed
    100 
    +                               , unusable_cyclic
    101 
    +                               , unusable_broken
    102 
    +                               , unusable_ignored
    103 
    +                               , directly_ignored
    104 
    +                               ]
    105 
    +
    106 
    +
    107 
    +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)
    108 
    +
    109 
    +-- | A unusable unit module origin
    110 
    +data UnusableUnit = UnusableUnit
    111 
    +  { uuUnit        :: !Unit               -- ^ Unusable unit
    112 
    +  , uuReason      :: !UnusableUnitReason -- ^ Reason
    113 
    +  , uuIsReexport  :: !Bool               -- ^ Is the "module" a reexport?
    114 
    +  }
    115 
    +
    116 
    +-- | The reason why a unit is unusable.
    117 
    +data UnusableUnitReason
    118 
    +  = -- | We ignored it explicitly using @-ignore-package@.
    119 
    +    IgnoredWithFlag
    120 
    +    -- | This unit transitively depends on a unit that was never present
    121 
    +    -- in any of the provided databases.
    122 
    +  | BrokenDependencies   [UnitId]
    123 
    +    -- | This unit transitively depends on a unit involved in a cycle.
    124 
    +    -- Note that the list of 'UnitId' reports the direct dependencies
    125 
    +    -- of this unit that (transitively) depended on the cycle, and not
    126 
    +    -- the actual cycle itself (which we report separately at high verbosity.)
    127 
    +  | CyclicDependencies   [UnitId]
    128 
    +    -- | This unit transitively depends on a unit which was ignored.
    129 
    +  | IgnoredDependencies  [UnitId]
    130 
    +    -- | This unit transitively depends on a unit which was
    131 
    +    -- shadowed by an ABI-incompatible unit.
    132 
    +  | ShadowedDependencies [UnitId]
    133 
    +
    134 
    +instance Outputable UnusableUnitReason where
    135 
    +    ppr IgnoredWithFlag = text "[ignored with flag]"
    136 
    +    ppr (BrokenDependencies uids)   = brackets (text "broken" <+> ppr uids)
    137 
    +    ppr (CyclicDependencies uids)   = brackets (text "cyclic" <+> ppr uids)
    138 
    +    ppr (IgnoredDependencies uids)  = brackets (text "ignored" <+> ppr uids)
    139 
    +    ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
    140 
    +
    141 
    +pprReason :: SDoc -> UnusableUnitReason -> SDoc
    142 
    +pprReason pref reason = case reason of
    143 
    +  IgnoredWithFlag ->
    144 
    +      pref <+> text "ignored due to an -ignore-package flag"
    145 
    +  BrokenDependencies deps ->
    146 
    +      pref <+> text "unusable due to missing dependencies:" $$
    147 
    +        nest 2 (hsep (map ppr deps))
    148 
    +  CyclicDependencies deps ->
    149 
    +      pref <+> text "unusable due to cyclic dependencies:" $$
    150 
    +        nest 2 (hsep (map ppr deps))
    151 
    +  IgnoredDependencies deps ->
    152 
    +      pref <+> text ("unusable because the -ignore-package flag was used to " ++
    153 
    +                     "ignore at least one of its dependencies:") $$
    154 
    +        nest 2 (hsep (map ppr deps))
    155 
    +  ShadowedDependencies deps ->
    156 
    +      pref <+> text "unusable due to shadowed dependencies:" $$
    157 
    +        nest 2 (hsep (map ppr deps))
    158 
    +
    159 
    +reportUnusable :: Logger -> UnusableUnits -> IO ()
    160 
    +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs)
    161 
    +  where
    162 
    +    report (ipid, (_, reason)) =
    163 
    +       debugTraceMsg logger 2 $
    164 
    +         pprReason
    165 
    +           (text "package" <+> ppr ipid <+> text "is") reason
    166 
    +
    167 
    +-- -----------------------------------------------------------------------------
    168 
    +-- Package Finding
    169 
    +
    170 
    +-- | Like 'selectPackages', but doesn't return a list of unmatched
    171 
    +-- packages.  Furthermore, any packages it returns are *renamed*
    172 
    +-- if the 'UnitArg' has a renaming associated with it.
    173 
    +findPackages :: UnitPrecedenceMap
    174 
    +             -> UnitInfoMap
    175 
    +             -> PackageArg -> [UnitInfo]
    176 
    +             -> UnusableUnits
    177 
    +             -> Either [(UnitInfo, UnusableUnitReason)]
    178 
    +                [UnitInfo]
    179 
    +findPackages prec_map pkg_map arg pkgs unusable
    180 
    +  = let ps = mapMaybe (finder arg) pkgs
    181 
    +    in if null ps
    182 
    +        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
    183 
    +                            (nonDetEltsUniqMap unusable))
    184 
    +        else Right (sortByPreference prec_map ps)
    185 
    +  where
    186 
    +    finder (PackageArg str) p
    187 
    +      = if matchingStr str p
    188 
    +          then Just p
    189 
    +          else Nothing
    190 
    +    finder (UnitIdArg uid) p
    191 
    +      = case uid of
    192 
    +          RealUnit (Definite iuid)
    193 
    +            | iuid == unitId p
    194 
    +            -> Just p
    195 
    +          VirtUnit inst
    196 
    +            | instUnitInstanceOf inst == unitId p
    197 
    +            -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p)
    198 
    +          _ -> Nothing
    199 
    +
    200 
    +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
    201 
    +               -> UnusableUnits
    202 
    +               -> Either [(UnitInfo, UnusableUnitReason)]
    203 
    +                  ([UnitInfo], [UnitInfo])
    204 
    +selectPackages prec_map arg pkgs unusable
    205 
    +  = let matches = matching arg
    206 
    +        (ps,rest) = partition matches pkgs
    207 
    +    in if null ps
    208 
    +        then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
    209 
    +        else Right (sortByPreference prec_map ps, rest)
    210 
    +
    211 
    +-- -----------------------------------------------------------------------------
    212 
    +-- Ignore units
    213 
    +
    214 
    +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
    215 
    +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags)
    216 
    +  where
    217 
    +  doit (IgnorePackage str) =
    218 
    +     case partition (matchingStr str) pkgs of
    219 
    +         (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
    220 
    +                    | p <- ps ]
    221 
    +        -- missing unit is not an error for -ignore-package,
    222 
    +        -- because a common usage is to -ignore-package P as
    223 
    +        -- a preventative measure just in case P exists.
    224 
    +
    225 
    +-- A package named on the command line can either include the
    226 
    +-- version, or just the name if it is unambiguous.
    227 
    +matchingStr :: String -> UnitInfo -> Bool
    228 
    +matchingStr str p
    229 
    +        =  str == unitPackageIdString p
    230 
    +        || str == unitPackageNameString p
    231 
    +
    232 
    +matchingId :: UnitId -> UnitInfo -> Bool
    233 
    +matchingId uid p = uid == unitId p
    234 
    +
    235 
    +matching :: PackageArg -> UnitInfo -> Bool
    236 
    +matching (PackageArg str) = matchingStr str
    237 
    +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
    238 
    +matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
    239 
    +
    240 
    +-- ----------------------------------------------------------------------------
    241 
    +--
    242 
    +-- Closures
    243 
    +--
    244 
    +
    245 
    +
    246 
    +-- | Takes a list of UnitIds (and their "parent" dependency, used for error
    247 
    +-- messages), and returns the list with dependencies included, in reverse
    248 
    +-- dependency order (a units appears before those it depends on).
    249 
    +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
    250 
    +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps
    251 
    +
    252 
    +-- | Similar to closeUnitDeps but takes a list of already loaded units as an
    253 
    +-- additional argument.
    254 
    +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
    255 
    +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps
    256 
    +
    257 
    +-- | Add a UnitId and those it depends on (recursively) to the given list of
    258 
    +-- UnitIds if they are not already in it. Return a list in reverse dependency
    259 
    +-- order (a unit appears before those it depends on).
    260 
    +--
    261 
    +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies).
    262 
    +-- It it's not found, the optional parent unit is used to return a more precise
    263 
    +-- error message ("dependency of <PARENT>").
    264 
    +add_unit :: UnitInfoMap
    265 
    +            -> [UnitId]
    266 
    +            -> UnitId
    267 
    +            -> Maybe UnitId
    268 
    +            -> MaybeErr UnitErr [UnitId]
    269 
    +add_unit pkg_map ps p mb_parent
    270 
    +  | p `elem` ps = return ps     -- Check if we've already added this unit
    271 
    +  | otherwise   = case lookupUnitId' pkg_map p of
    272 
    +      Nothing   -> Failed (CloseUnitErr p mb_parent)
    273 
    +      Just info -> do
    274 
    +         -- Add the unit's dependents also
    275 
    +         ps' <- foldM add_unit_key ps (unitDepends info)
    276 
    +         return (p : ps')
    277 
    +        where
    278 
    +          add_unit_key xs key
    279 
    +            = add_unit pkg_map xs key (Just p)
    280 
    +data UnitErr
    281 
    +  = CloseUnitErr !UnitId !(Maybe UnitId)
    282 
    +  | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
    283 
    +  | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]
    284 
    +
    285 
    +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
    286 
    +mayThrowUnitErr = \case
    287 
    +    Failed e    -> throwGhcExceptionIO
    288 
    +                    $ CmdLineError
    289 
    +                    $ renderWithContext defaultSDocContext
    290 
    +                    $ withPprStyle defaultUserStyle
    291 
    +                    $ ppr e
    292 
    +    Succeeded a -> return a
    293 
    +
    294 
    +instance Outputable UnitErr where
    295 
    +    ppr = \case
    296 
    +        CloseUnitErr p mb_parent
    297 
    +            -> (text "unknown unit:" <+> ppr p)
    298 
    +               <> case mb_parent of
    299 
    +                     Nothing     -> Outputable.empty
    300 
    +                     Just parent -> space <> parens (text "dependency of"
    301 
    +                                              <+> ftext (unitIdFS parent))
    302 
    +        PackageFlagErr flag reasons
    303 
    +            -> flag_err (pprFlag flag) reasons
    304 
    +
    305 
    +        TrustFlagErr flag reasons
    306 
    +            -> flag_err (pprTrustFlag flag) reasons
    307 
    +      where
    308 
    +        flag_err flag_doc reasons =
    309 
    +            text "cannot satisfy "
    310 
    +            <> flag_doc
    311 
    +            <> (if null reasons then Outputable.empty else text ": ")
    312 
    +            $$ nest 4 (vcat (map ppr_reason reasons) $$
    313 
    +                      text "(use -v for more information)")
    314 
    +
    315 
    +        ppr_reason (p, reason) =
    316 
    +            pprReason (ppr (unitId p) <+> text "is") reason
    317 
    +
    318 
    +
    319 
    +pprFlag :: PackageFlag -> SDoc
    320 
    +pprFlag flag = case flag of
    321 
    +    HidePackage p   -> text "-hide-package " <> text p
    322 
    +    ExposePackage doc _ _ -> text doc
    323 
    +
    324 
    +pprTrustFlag :: TrustFlag -> SDoc
    325 
    +pprTrustFlag flag = case flag of
    326 
    +    TrustPackage p    -> text "-trust " <> text p
    327 
    +    DistrustPackage p -> text "-distrust " <> text p
    328 
    +
    329 
    +-- ----------------------------------------------------------------------------
    330 
    +--
    331 
    +-- Utilities on the database
    332 
    +--
    333 
    +
    334 
    +-- | A reverse dependency index, mapping an 'UnitId' to
    335 
    +-- the 'UnitId's which have a dependency on it.
    336 
    +type RevIndex = UniqMap UnitId [UnitId]
    337 
    +
    338 
    +-- | Compute the reverse dependency index of a unit database.
    339 
    +reverseDeps :: UnitInfoMap -> RevIndex
    340 
    +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db
    341 
    +  where
    342 
    +    go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
    343 
    +    go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg)
    344 
    +    go' from r to = addToUniqMap_C (++) r to [from]
    345 
    +
    346 
    +-- | Given a list of 'UnitId's to remove, a database,
    347 
    +-- and a reverse dependency index (as computed by 'reverseDeps'),
    348 
    +-- remove those units, plus any units which depend on them.
    349 
    +-- Returns the pruned database, as well as a list of 'UnitInfo's
    350 
    +-- that was removed.
    351 
    +removeUnits :: [UnitId] -> RevIndex
    352 
    +               -> UnitInfoMap
    353 
    +               -> (UnitInfoMap, [UnitInfo])
    354 
    +removeUnits uids index m = go uids (m,[])
    355 
    +  where
    356 
    +    go [] (m,pkgs) = (m,pkgs)
    357 
    +    go (uid:uids) (m,pkgs)
    358 
    +        | Just pkg <- lookupUniqMap m uid
    359 
    +        = case lookupUniqMap index uid of
    360 
    +            Nothing    -> go uids (delFromUniqMap m uid, pkg:pkgs)
    361 
    +            Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs)
    362 
    +        | otherwise
    363 
    +        = go uids (m,pkgs)
    364 
    +
    365 
    +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'
    366 
    +-- which correspond to units that do not exist in the index.
    367 
    +depsNotAvailable :: UnitInfoMap
    368 
    +                 -> UnitInfo
    369 
    +                 -> [UnitId]
    370 
    +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg)
    371 
    +
    372 
    +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
    373 
    +-- 'unitAbiDepends' which correspond to units that do not exist, OR have
    374 
    +-- mismatching ABIs.
    375 
    +depsAbiMismatch :: UnitInfoMap
    376 
    +                -> UnitInfo
    377 
    +                -> [UnitId]
    378 
    +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg
    379 
    +  where
    380 
    +    abiMatch (dep_uid, abi)
    381 
    +        | Just dep_pkg <- lookupUniqMap pkg_map dep_uid
    382 
    +        = unitAbiHash dep_pkg == abi
    383 
    +        | otherwise
    384 
    +        = False

  • compiler/GHC/Unit/External/Visibility.hs
    1 
    +module GHC.Unit.External.Visibility (
    2 
    +  VisibilityMap,
    3 
    +  UnitVisibility(..),
    4 
    +) where
    5 
    +
    6 
    +import GHC.Prelude
    7 
    +
    8 
    +import GHC.Data.FastString
    9 
    +import GHC.Driver.DynFlags
    10 
    +import GHC.Types.Unique.Map
    11 
    +import GHC.Unit.Module
    12 
    +import GHC.Utils.Outputable as Outputable
    13 
    +
    14 
    +import Control.Applicative
    15 
    +import Data.Monoid (First (..))
    16 
    +import Data.Semigroup qualified as Semigroup
    17 
    +import Data.Set (Set)
    18 
    +import Data.Set qualified as Set
    19 
    +
    20 
    +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
    21 
    +type VisibilityMap = UniqMap Unit UnitVisibility
    22 
    +
    23 
    +-- | 'UnitVisibility' records the various aspects of visibility of a particular
    24 
    +-- 'Unit'.
    25 
    +data UnitVisibility = UnitVisibility
    26 
    +    { uv_expose_all :: Bool
    27 
    +      --  ^ Should all modules in exposed-modules should be dumped into scope?
    28 
    +    , uv_renamings :: [(ModuleName, ModuleName)]
    29 
    +      -- ^ Any custom renamings that should bring extra 'ModuleName's into
    30 
    +      -- scope.
    31 
    +    , uv_package_name :: First FastString
    32 
    +      -- ^ The package name associated with the 'Unit'.  This is used
    33 
    +      -- to implement legacy behavior where @-package foo-0.1@ implicitly
    34 
    +      -- hides any packages named @foo@
    35 
    +    , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
    36 
    +      -- ^ The signatures which are contributed to the requirements context
    37 
    +      -- from this unit ID.
    38 
    +    , uv_explicit :: Maybe PackageArg
    39 
    +      -- ^ Whether or not this unit was explicitly brought into scope,
    40 
    +      -- as opposed to implicitly via the 'exposed' fields in the
    41 
    +      -- package database (when @-hide-all-packages@ is not passed.)
    42 
    +    }
    43 
    +
    44 
    +instance Outputable UnitVisibility where
    45 
    +    ppr (UnitVisibility {
    46 
    +        uv_expose_all = b,
    47 
    +        uv_renamings = rns,
    48 
    +        uv_package_name = First mb_pn,
    49 
    +        uv_requirements = reqs,
    50 
    +        uv_explicit = explicit
    51 
    +    }) = ppr (b, rns, mb_pn, reqs, explicit)
    52 
    +
    53 
    +instance Semigroup UnitVisibility where
    54 
    +    uv1 <> uv2
    55 
    +        = UnitVisibility
    56 
    +          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
    57 
    +          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
    58 
    +          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
    59 
    +          , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1)
    60 
    +          , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2
    61 
    +          }
    62 
    +
    63 
    +instance Monoid UnitVisibility where
    64 
    +    mempty = UnitVisibility
    65 
    +             { uv_expose_all = False
    66 
    +             , uv_renamings = []
    67 
    +             , uv_package_name = First Nothing
    68 
    +             , uv_requirements = emptyUniqMap
    69 
    +             , uv_explicit = Nothing
    70 
    +             }
    71 
    +    mappend = (Semigroup.<>)
    72 
    +

  • compiler/GHC/Unit/External/Wired.hs
    1 
    +module GHC.Unit.External.Wired (
    2 
    +  WiringMap,
    3 
    +  UnwiringMap,
    4 
    +  findWiredInUnits,
    5 
    +) where
    6 
    +
    7 
    +import GHC.Prelude
    8 
    +
    9 
    +import GHC.Data.Maybe
    10 
    +import GHC.Types.Unique.Map
    11 
    +import GHC.Unit.Database
    12 
    +import GHC.Unit.External.Database
    13 
    +import GHC.Unit.External.Visibility
    14 
    +import GHC.Unit.Info
    15 
    +import GHC.Unit.Types
    16 
    +import GHC.Utils.Error
    17 
    +import GHC.Utils.Logger
    18 
    +import GHC.Utils.Outputable as Outputable
    19 
    +
    20 
    +type WiringMap =
    21 
    +  UniqMap UnitId UnitId
    22 
    +
    23 
    +type UnwiringMap =
    24 
    +  UniqMap UnitId UnitId
    25 
    +
    26 
    +-- -----------------------------------------------------------------------------
    27 
    +-- Wired-in units
    28 
    +--
    29 
    +-- See Note [Wired-in units] in GHC.Unit.Types
    30 
    +
    31 
    +findWiredInUnits
    32 
    +   :: Logger
    33 
    +   -> UnitPrecedenceMap
    34 
    +   -> [UnitInfo]           -- database
    35 
    +   -> VisibilityMap             -- info on what units are visible
    36 
    +                                -- for wired in selection
    37 
    +   -> IO WiringMap   -- map from unit id to wired identity
    38 
    +findWiredInUnits logger prec_map pkgs vis_map = do
    39 
    +  -- Now we must find our wired-in units, and rename them to
    40 
    +  -- their canonical names (eg. base-1.0 ==> base), as described
    41 
    +  -- in Note [Wired-in units] in GHC.Unit.Types
    42 
    +  let
    43 
    +        matches :: UnitInfo -> UnitId -> Bool
    44 
    +        pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
    45 
    +
    46 
    +        -- find which package corresponds to each wired-in package
    47 
    +        -- delete any other packages with the same name
    48 
    +        -- update the package and any dependencies to point to the new
    49 
    +        -- one.
    50 
    +        --
    51 
    +        -- When choosing which package to map to a wired-in package
    52 
    +        -- name, we try to pick the latest version of exposed packages.
    53 
    +        -- However, if there are no exposed wired in packages available
    54 
    +        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
    55 
    +        -- to assign a package for the wired-in package: so we try again
    56 
    +        -- with hidden packages included to (and pick the latest
    57 
    +        -- version).
    58 
    +        --
    59 
    +        -- You can also override the default choice by using -ignore-package:
    60 
    +        -- this works even when there is no exposed wired in package
    61 
    +        -- available.
    62 
    +        --
    63 
    +        findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
    64 
    +        findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound]
    65 
    +          where
    66 
    +                all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
    67 
    +                all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ]
    68 
    +
    69 
    +                try ps = case sortByPreference prec_map ps of
    70 
    +                    p:_ -> Just <$> pick p
    71 
    +                    _ -> pure Nothing
    72 
    +
    73 
    +                notfound = do
    74 
    +                          debugTraceMsg logger 2 $
    75 
    +                            text "wired-in package "
    76 
    +                                 <> ftext (unitIdFS wired_pkg)
    77 
    +                                 <> text " not found."
    78 
    +                          return Nothing
    79 
    +                pick :: UnitInfo -> IO (UnitId, UnitInfo)
    80 
    +                pick pkg = do
    81 
    +                        debugTraceMsg logger 2 $
    82 
    +                            text "wired-in package "
    83 
    +                                 <> ftext (unitIdFS wired_pkg)
    84 
    +                                 <> text " mapped to "
    85 
    +                                 <> ppr (unitId pkg)
    86 
    +                        return (wired_pkg, pkg)
    87 
    +
    88 
    +
    89 
    +  mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds
    90 
    +  let
    91 
    +        wired_in_pkgs = catMaybes mb_wired_in_pkgs
    92 
    +
    93 
    +        wiredInMap :: UniqMap UnitId UnitId
    94 
    +        wiredInMap = listToUniqMap
    95 
    +          [ (unitId realUnitInfo, wiredInUnitId)
    96 
    +          | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
    97 
    +          , not (unitIsIndefinite realUnitInfo)
    98 
    +          ]
    99 
    +
    100 
    +  return wiredInMap

  • compiler/GHC/Unit/Info.hs
    ... ... @@ -5,11 +5,14 @@ module GHC.Unit.Info
    5 5 
        ( GenericUnitInfo (..)
    6 6 
        , GenUnitInfo
    7 7 
        , UnitInfo
    8 
    +   , UnitInfoMap
    8 9 
        , UnitKey (..)
    9 10 
        , UnitKeyInfo
    10 11 
        , mkUnitKeyInfo
    11 12 
        , mapUnitInfo
    12 13 
        , mkUnitPprInfo
    14 
    +   , evaluateUnitInfo
    15 
    +   , seqUnitInfo
    13 16
    14 17 
        , mkUnit
    15 18
    ... ... @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd)
    53 56 
     import Data.Version
    54 57 
     import Data.Bifunctor
    55 58 
     import Data.List (isPrefixOf, stripPrefix)
    59 
    +import GHC.Types.Unique.Map
    60 
    +import Control.Exception (evaluate)
    56 61
    57 62
    58 63 
     -- | Information about an installed unit
    ... ... @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey
    73 78 
     -- UnitId)
    74 79 
     type UnitInfo    = GenUnitInfo UnitId
    75 80
    81 
    +-- TODO @fendor
    82 
    +type UnitInfoMap = UniqMap UnitId UnitInfo
    83 
    +
    76 84 
     -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo`
    77 85 
     mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo
    78 86 
     mkUnitKeyInfo = mapGenericUnitInfo
    ... ... @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar
    250 258
    251 259 
             expandTag t | null t = ""
    252 260 
                         | otherwise = '_':t
    261 
    +
    262 
    +evaluateUnitInfo :: UnitInfo -> IO UnitInfo
    263 
    +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui)
    264 
    +
    265 
    +seqUnitInfo :: UnitInfo -> b -> b
    266 
    +seqUnitInfo ui b =
    267 
    +  unitImportDirs ui `seqList`
    268 
    +  unitIncludeDirs ui `seqList`
    269 
    +  unitLibraryDirs ui `seqList`
    270 
    +  unitLibraryBytecodeDirs ui `seqList`
    271 
    +  unitExtDepFrameworkDirs ui `seq`
    272 
    +  unitHaddockInterfaces ui `seq`
    273 
    +  unitHaddockHTMLs ui `seqList`
    274 
    +  unitLibraryDynDirs ui `seqList`
    275 
    +  unitLibraryDirsStatic ui `seqList`
    276 
    +  unitDepends ui `seqList`
    277 
    +  unitExposedModules ui `seqList`
    278 
    +  b

  • compiler/GHC/Unit/State.hs
    ... ... @@ -5,7 +5,7 @@
    5 5 
     module GHC.Unit.State (
    6 6 
             module GHC.Unit.Info,
    7 7
    8 
    -        UnitIndex(..),
    8 
    +        UnitIndex,
    9 9 
             initUnitIndex,
    10 10 
             setWireMap,
    11 11 
             isWireMapEmpty,
    ... ... @@ -26,7 +26,6 @@ module GHC.Unit.State (
    26 26 
             listUnitInfo,
    27 27
    28 28 
             -- * Querying the package config
    29 
    -        UnitInfoMap,
    30 29 
             lookupUnit,
    31 30 
             lookupUnit',
    32 31 
             unsafeLookupUnit,
    ... ... @@ -90,50 +89,45 @@ import GHC.Platform
    90 89 
     import GHC.Platform.Ways
    91 90
    92 91 
     import GHC.Unit.Database
    92 
    +import GHC.Unit.Home
    93 93 
     import GHC.Unit.Info
    94 
    -import GHC.Unit.Ppr
    95 
    -import GHC.Unit.Types
    96 94 
     import GHC.Unit.Module
    97 
    -import GHC.Unit.Home
    95 
    +import GHC.Unit.Ppr
    98 96
    99 
    -import GHC.Types.Unique.FM
    97 
    +import GHC.Unit.External.Database
    98 
    +import GHC.Unit.External.Index
    99 
    +import GHC.Unit.External.ModuleOrigin
    100 
    +import GHC.Unit.External.Providers
    101 
    +import GHC.Unit.External.Query
    102 
    +import GHC.Unit.External.Substitution
    103 
    +import GHC.Unit.External.Validate
    104 
    +import GHC.Unit.External.Visibility
    105 
    +import GHC.Unit.External.Wired
    106 
    +
    107 
    +import GHC.Types.PkgQual
    100 108 
     import GHC.Types.Unique.DFM
    101 
    -import GHC.Types.Unique.DSet
    109 
    +import GHC.Types.Unique.FM
    102 110 
     import GHC.Types.Unique.Map
    103 
    -import GHC.Types.Unique
    104 
    -import GHC.Types.PkgQual
    105 111
    106 
    -import GHC.Utils.Misc
    107 
    -import GHC.Utils.Panic
    108 
    -import GHC.Utils.Outputable as Outputable
    109 
    -import GHC.Data.Maybe
    110 
    -
    111 
    -import System.Environment ( getEnv )
    112 112 
     import GHC.Data.FastString
    113 
    -import GHC.Data.OsPath ( OsPath )
    114 
    -import qualified GHC.Data.OsPath as OsPath
    115 
    -import qualified GHC.Data.ShortText as ST
    116 
    -import GHC.Utils.Logger
    113 
    +import GHC.Data.Maybe
    114 
    +import GHC.Data.OsPath qualified as OsPath
    115 
    +import GHC.Data.ShortText qualified as ST
    117 116 
     import GHC.Utils.Error
    118 
    -import GHC.Utils.Exception
    117 
    +import GHC.Utils.Logger
    118 
    +import GHC.Utils.Misc
    119 
    +import GHC.Utils.Outputable as Outputable
    120 
    +import GHC.Utils.Panic
    119 121
    120 
    -import System.Directory
    121 
    -import System.FilePath as FilePath
    122 122 
     import Control.Monad
    123 123 
     import Data.Containers.ListUtils (nubOrd)
    124 
    -import Data.Graph (stronglyConnComp, SCC(..))
    125 
    -import Data.Char ( toUpper )
    126 
    -import Data.List ( intersperse, partition, sortBy, sortOn, sort )
    127 
    -import Data.Set (Set)
    128 
    -import Data.Monoid (First(..))
    129 
    -import qualified Data.Semigroup as Semigroup
    130 
    -import qualified Data.Set as Set
    131 
    -import Control.Applicative
    132 
    -import GHC.Unit.External.Database
    133 
    -import Data.IORef
    134 124 
     import Data.Either (partitionEithers)
    135 
    -import Data.Map.Strict (Map)
    136 
    -import qualified Data.Map.Strict as Map
    125 
    +import Data.Graph (SCC (..))
    126 
    +import Data.IORef
    127 
    +import Data.List (intersperse, partition, sort, sortOn)
    128 
    +import Data.Monoid (First (..))
    129 
    +import Data.Set (Set)
    130 
    +import Data.Set qualified as Set
    137 131
    138 132 
     -- ---------------------------------------------------------------------------
    139 133 
     -- The Unit state
    ... ... @@ -179,162 +173,6 @@ import qualified Data.Map.Strict as Map
    179 173 
     -- When compiling A, we record in B's Module value whether it's
    180 174 
     -- in a different DLL, by setting the DLL flag.
    181 175
    182 
    --- | Given a module name, there may be multiple ways it came into scope,
    183 
    --- possibly simultaneously.  This data type tracks all the possible ways
    184 
    --- it could have come into scope.  Warning: don't use the record functions,
    185 
    --- they're partial!
    186 
    -data ModuleOrigin =
    187 
    -    -- | Module is hidden, and thus never will be available for import.
    188 
    -    -- (But maybe the user didn't realize), so we'll still keep track
    189 
    -    -- of these modules.)
    190 
    -    ModHidden
    191 
    -
    192 
    -    -- | Module is unavailable because the unit is unusable.
    193 
    -  | ModUnusable !UnusableUnit
    194 
    -
    195 
    -    -- | Module is public, and could have come from some places.
    196 
    -  | ModOrigin {
    197 
    -        -- | @Just False@ means that this module is in
    198 
    -        -- someone's @exported-modules@ list, but that package is hidden;
    199 
    -        -- @Just True@ means that it is available; @Nothing@ means neither
    200 
    -        -- applies.
    201 
    -        fromOrigUnit :: Maybe Bool
    202 
    -        -- | Is the module available from a reexport of an exposed package?
    203 
    -        -- There could be multiple.
    204 
    -      , fromExposedReexport :: [UnitInfo]
    205 
    -        -- | Is the module available from a reexport of a hidden package?
    206 
    -      , fromHiddenReexport :: [UnitInfo]
    207 
    -        -- | Did the module export come from a package flag? (ToDo: track
    208 
    -        -- more information.
    209 
    -      , fromPackageFlag :: Bool
    210 
    -      }
    211 
    -
    212 
    --- | A unusable unit module origin
    213 
    -data UnusableUnit = UnusableUnit
    214 
    -  { uuUnit        :: !Unit               -- ^ Unusable unit
    215 
    -  , uuReason      :: !UnusableUnitReason -- ^ Reason
    216 
    -  , uuIsReexport  :: !Bool               -- ^ Is the "module" a reexport?
    217 
    -  }
    218 
    -
    219 
    -instance Outputable ModuleOrigin where
    220 
    -    ppr ModHidden = text "hidden module"
    221 
    -    ppr (ModUnusable _) = text "unusable module"
    222 
    -    ppr (ModOrigin e res rhs f) = sep (punctuate comma (
    223 
    -        (case e of
    224 
    -            Nothing -> []
    225 
    -            Just False -> [text "hidden package"]
    226 
    -            Just True -> [text "exposed package"]) ++
    227 
    -        (if null res
    228 
    -            then []
    229 
    -            else [text "reexport by" <+>
    230 
    -                    sep (map (ppr . mkUnit) res)]) ++
    231 
    -        (if null rhs
    232 
    -            then []
    233 
    -            else [text "hidden reexport by" <+>
    234 
    -                    sep (map (ppr . mkUnit) rhs)]) ++
    235 
    -        (if f then [text "package flag"] else [])
    236 
    -        ))
    237 
    -
    238 
    --- | Smart constructor for a module which is in @exposed-modules@.  Takes
    239 
    --- as an argument whether or not the defining package is exposed.
    240 
    -fromExposedModules :: Bool -> ModuleOrigin
    241 
    -fromExposedModules e = ModOrigin (Just e) [] [] False
    242 
    -
    243 
    --- | Smart constructor for a module which is in @reexported-modules@.  Takes
    244 
    --- as an argument whether or not the reexporting package is exposed, and
    245 
    --- also its 'UnitInfo'.
    246 
    -fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
    247 
    -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
    248 
    -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
    249 
    -
    250 
    --- | Smart constructor for a module which was bound by a package flag.
    251 
    -fromFlag :: ModuleOrigin
    252 
    -fromFlag = ModOrigin Nothing [] [] True
    253 
    -
    254 
    -instance Semigroup ModuleOrigin where
    255 
    -    x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') =
    256 
    -        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
    257 
    -      where g (Just b) (Just b')
    258 
    -                | b == b'   = Just b
    259 
    -                | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $
    260 
    -                    text "x: " <> ppr x $$ text "y: " <> ppr y
    261 
    -            g Nothing x = x
    262 
    -            g x Nothing = x
    263 
    -
    264 
    -    x <> y = pprPanic "ModOrigin: module origin mismatch" $
    265 
    -                 text "x: " <> ppr x $$ text "y: " <> ppr y
    266 
    -
    267 
    -instance Monoid ModuleOrigin where
    268 
    -    mempty = ModOrigin Nothing [] [] False
    269 
    -    mappend = (Semigroup.<>)
    270 
    -
    271 
    --- | Is the name from the import actually visible? (i.e. does it cause
    272 
    --- ambiguity, or is it only relevant when we're making suggestions?)
    273 
    -originVisible :: ModuleOrigin -> Bool
    274 
    -originVisible ModHidden = False
    275 
    -originVisible (ModUnusable _) = False
    276 
    -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
    277 
    -
    278 
    --- | Are there actually no providers for this module?  This will never occur
    279 
    --- except when we're filtering based on package imports.
    280 
    -originEmpty :: ModuleOrigin -> Bool
    281 
    -originEmpty (ModOrigin Nothing [] [] False) = True
    282 
    -originEmpty _ = False
    283 
    -
    284 
    --- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'.
    285 
    -type VisibilityMap = UniqMap Unit UnitVisibility
    286 
    -
    287 
    --- | 'UnitVisibility' records the various aspects of visibility of a particular
    288 
    --- 'Unit'.
    289 
    -data UnitVisibility = UnitVisibility
    290 
    -    { uv_expose_all :: Bool
    291 
    -      --  ^ Should all modules in exposed-modules should be dumped into scope?
    292 
    -    , uv_renamings :: [(ModuleName, ModuleName)]
    293 
    -      -- ^ Any custom renamings that should bring extra 'ModuleName's into
    294 
    -      -- scope.
    295 
    -    , uv_package_name :: First FastString
    296 
    -      -- ^ The package name associated with the 'Unit'.  This is used
    297 
    -      -- to implement legacy behavior where @-package foo-0.1@ implicitly
    298 
    -      -- hides any packages named @foo@
    299 
    -    , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
    300 
    -      -- ^ The signatures which are contributed to the requirements context
    301 
    -      -- from this unit ID.
    302 
    -    , uv_explicit :: Maybe PackageArg
    303 
    -      -- ^ Whether or not this unit was explicitly brought into scope,
    304 
    -      -- as opposed to implicitly via the 'exposed' fields in the
    305 
    -      -- package database (when @-hide-all-packages@ is not passed.)
    306 
    -    }
    307 
    -
    308 
    -instance Outputable UnitVisibility where
    309 
    -    ppr (UnitVisibility {
    310 
    -        uv_expose_all = b,
    311 
    -        uv_renamings = rns,
    312 
    -        uv_package_name = First mb_pn,
    313 
    -        uv_requirements = reqs,
    314 
    -        uv_explicit = explicit
    315 
    -    }) = ppr (b, rns, mb_pn, reqs, explicit)
    316 
    -
    317 
    -instance Semigroup UnitVisibility where
    318 
    -    uv1 <> uv2
    319 
    -        = UnitVisibility
    320 
    -          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
    321 
    -          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
    322 
    -          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
    323 
    -          , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1)
    324 
    -          , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2
    325 
    -          }
    326 
    -
    327 
    -instance Monoid UnitVisibility where
    328 
    -    mempty = UnitVisibility
    329 
    -             { uv_expose_all = False
    330 
    -             , uv_renamings = []
    331 
    -             , uv_package_name = First Nothing
    332 
    -             , uv_requirements = emptyUniqMap
    333 
    -             , uv_explicit = Nothing
    334 
    -             }
    335 
    -    mappend = (Semigroup.<>)
    336 
    -
    337 
    -
    338 176 
     -- | Unit configuration
    339 177 
     data UnitConfig = UnitConfig
    340 178 
        { unitConfigPlatformArchOS :: !ArchOS        -- ^ Platform arch and OS
    ... ... @@ -422,77 +260,6 @@ initUnitConfig dflags cached_dbs home_units =
    422 260 
         offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p))
    423 261 
         offsetPackageDb _ p = p
    424 262
    425 
    -
    426 
    --- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and
    427 
    --- its 'ModuleOrigin').
    428 
    ---
    429 
    --- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
    430 
    --- origin for a given 'Module'
    431 
    -
    432 
    -type ModuleNameProvidersMap =
    433 
    -    UniqMap ModuleName (UniqMap Module ModuleOrigin)
    434 
    -
    435 
    -data GlobalUnitKey =
    436 
    -  GlobalUnitKey
    437 
    -    !UnitId -- ^ Unit Id of the 'UnitInfo'
    438 
    -    !ST.ShortText
    439 
    -
    440 
    -globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey
    441 
    -globalUnitKeyFromUnitInfo ui = GlobalUnitKey (unitId ui) (unitAbiHash ui)
    442 
    -
    443 
    -type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo)
    444 
    -
    445 
    -lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo
    446 
    -lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap =
    447 
    -  case lookupUniqMap globalMap uid of
    448 
    -    Nothing -> Nothing
    449 
    -    Just sameUnitId -> Map.lookup abiHash sameUnitId
    450 
    -
    451 
    -mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap
    452 
    -mkGlobalUnitInfoMap unitInfos =
    453 
    -  listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos
    454 
    -
    455 
    -
    456 
    -data UnitIndex = UnitIndex
    457 
    -  { ui_wireMap :: !WiringMap
    458 
    -  -- ^ TODO @fendor: document global property
    459 
    -  , ui_unwireMap :: !UnwiringMap
    460 
    -  -- ^ TODO @fendor: document global property
    461 
    -  , ui_unitInfoMap :: !GlobalUnitInfoMap
    462 
    -  -- ^ TODO @fendor: document
    463 
    -  }
    464 
    -
    465 
    -initUnitIndex :: UnitIndex
    466 
    -initUnitIndex = UnitIndex
    467 
    -  { ui_wireMap = emptyUniqMap
    468 
    -  , ui_unwireMap = emptyUniqMap
    469 
    -  , ui_unitInfoMap = emptyUniqMap
    470 
    -  }
    471 
    -
    472 
    -setWireMap :: WiringMap -> UnitIndex -> UnitIndex
    473 
    -setWireMap wired_map unit_index =
    474 
    -  unit_index
    475 
    -    { ui_wireMap = wired_map
    476 
    -    , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    477 
    -    }
    478 
    -
    479 
    -isWireMapEmpty :: UnitIndex -> Bool
    480 
    -isWireMapEmpty unit_index =
    481 
    -  isNullUniqMap (ui_wireMap unit_index)
    482 
    -
    483 
    -addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex
    484 
    -addUnitInfoMap unit_info_map unit_index =
    485 
    -  unit_index
    486 
    -    { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index)
    487 
    -    }
    488 
    -  where
    489 
    -    globalMap :: GlobalUnitInfoMap
    490 
    -    globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map
    491 
    -
    492 
    --- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo
    493 
    --- lookupUnitInfoMap unit_index unit_id =
    494 
    ---   lookupUniqMap (ui_unitInfoMap unit_index) unit_id
    495 
    -
    496 263 
     data UnitState = UnitState {
    497 264 
       -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
    498 265 
       -- so that only valid units are here.  'UnitInfo' reflects
    ... ... @@ -513,12 +280,6 @@ data UnitState = UnitState {
    513 280 
       -- And also to resolve package qualifiers with the PackageImports extension.
    514 281 
       packageNameMap            :: UniqFM PackageName UnitId,
    515 282
    516 
    -  -- -- | A mapping from database unit keys to wired in unit ids.
    517 
    -  -- wireMap :: WiringMap,
    518 
    -
    519 
    -  -- -- | A mapping from wired in unit ids to unit keys from the database.
    520 
    -  -- unwireMap :: UnwiringMap,
    521 
    -
    522 283 
       -- | The units we're going to link in eagerly.  This list
    523 284 
       -- should be in reverse dependency order; that is, a unit
    524 285 
       -- is always mentioned before the units it depends on.
    ... ... @@ -573,45 +334,14 @@ emptyUnitState = UnitState {
    573 334 
         allowVirtualUnits = False
    574 335 
         }
    575 336
    576 
    -type UnitInfoMap = UniqMap UnitId UnitInfo
    577 
    -
    578 337 
     -- | Find the unit we know about with the given unit, if any
    579 338 
     lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
    580 339 
     lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs)
    581 340
    582 
    --- | A more specialized interface, which doesn't require a 'UnitState' (so it
    583 
    --- can be used while we're initializing 'DynFlags')
    584 
    ---
    585 
    --- Parameters:
    586 
    ---    * a boolean specifying whether or not to look for on-the-fly renamed interfaces
    587 
    ---    * a 'UnitInfoMap'
    588 
    -lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo
    589 
    -lookupUnit' allowOnTheFlyInst pkg_map u = case u of
    590 
    -   HoleUnit   -> error "Hole unit"
    591 
    -   RealUnit i -> lookupUniqMap pkg_map (unDefinite i)
    592 
    -   VirtUnit i
    593 
    -      | allowOnTheFlyInst
    594 
    -      -> -- lookup UnitInfo of the indefinite unit to be instantiated and
    595 
    -         -- instantiate it on-the-fly
    596 
    -         fmap (renameUnitInfo pkg_map (instUnitInsts i))
    597 
    -           (lookupUniqMap pkg_map (instUnitInstanceOf i))
    598 
    -
    599 
    -      | otherwise
    600 
    -      -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite
    601 
    -         -- units. Even if they are real, installed units, they can't use the
    602 
    -         -- `RealUnit` constructor (it is reserved for definite units) so we use
    603 
    -         -- the `VirtUnit` constructor.
    604 
    -         lookupUniqMap pkg_map (virtualUnitId i)
    605 
    -
    606 341 
     -- | Find the unit we know about with the given unit id, if any
    607 342 
     lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
    608 343 
     lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid
    609 344
    610 
    --- | Find the unit we know about with the given unit id, if any
    611 
    -lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
    612 
    -lookupUnitId' db uid = lookupUniqMap db uid
    613 
    -
    614 
    -
    615 345 
     -- | Looks up the given unit in the unit state, panicking if it is not found
    616 346 
     unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
    617 347 
     unsafeLookupUnit state u = case lookupUnit state u of
    ... ... @@ -729,7 +459,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do
    729 459 
         FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
    730 460 
                     $ pprModuleMap (moduleNameProvidersMap unit_state))
    731 461
    732 
    -  wireMap <- ui_wireMap <$> readIORef unit_index
    462 
    +  wireMap <- wiringMap <$> readIORef unit_index
    733 463
    734 464 
       let home_unit = mkHomeUnit wireMap
    735 465 
                                  (homeUnitId_ dflags)
    ... ... @@ -782,205 +512,6 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ =
    782 512 
              | otherwise
    783 513 
              -> DefiniteHomeUnit hu_id (Just (u, is))
    784 514
    785 
    --- -----------------------------------------------------------------------------
    786 
    --- Reading the unit database(s)
    787 
    -
    788 
    -readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
    789 
    -readUnitDatabases logger cfg = do
    790 
    -  conf_refs <- getUnitDbRefs cfg
    791 
    -  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
    792 
    -  mapM (readOrGetUnitDatabase logger cfg) confs
    793 
    -
    794 
    -
    795 
    -getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
    796 
    -getUnitDbRefs cfg = do
    797 
    -  let system_conf_refs = [UserPkgDb, GlobalPkgDb]
    798 
    -
    799 
    -  e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH")
    800 
    -  let base_conf_refs = case e_pkg_path of
    801 
    -        Left _ -> system_conf_refs
    802 
    -        Right path
    803 
    -         | Just (xs, x) <- snocView path, isSearchPathSeparator x
    804 
    -         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs
    805 
    -         | otherwise
    806 
    -         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))
    807 
    -
    808 
    -  -- Apply the package DB-related flags from the command line to get the
    809 
    -  -- final list of package DBs.
    810 
    -  --
    811 
    -  -- Notes on ordering:
    812 
    -  --  * The list of flags is reversed (later ones first)
    813 
    -  --  * We work with the package DB list in "left shadows right" order
    814 
    -  --  * and finally reverse it at the end, to get "right shadows left"
    815 
    -  --
    816 
    -  return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg))
    817 
    - where
    818 
    -  doFlag (PackageDB p) dbs = p : dbs
    819 
    -  doFlag NoUserPackageDB dbs = filter isNotUser dbs
    820 
    -  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
    821 
    -  doFlag ClearPackageDBs _ = []
    822 
    -
    823 
    -  isNotUser UserPkgDb = False
    824 
    -  isNotUser _ = True
    825 
    -
    826 
    -  isNotGlobal GlobalPkgDb = False
    827 
    -  isNotGlobal _ = True
    828 
    -
    829 
    --- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'
    830 
    --- when the user database filepath is expected but the latter doesn't exist.
    831 
    ---
    832 
    --- NB: This logic is reimplemented in Cabal, so if you change it,
    833 
    --- make sure you update Cabal. (Or, better yet, dump it in the
    834 
    --- compiler info so Cabal can use the info.)
    835 
    -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath)
    836 
    -resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg
    837 
    -resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
    838 
    -  dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
    839 
    -  let pkgconf = dir </> unitConfigDBName cfg
    840 
    -  exist <- tryMaybeT $ doesDirectoryExist pkgconf
    841 
    -  if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
    842 
    -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
    843 
    -
    844 
    --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
    845 
    -readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
    846 
    -readOrGetUnitDatabase logger cfg conf_file =
    847 
    -  readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case
    848 
    -    Nothing -> do
    849 
    -      new_db <- readUnitDatabase logger cfg conf_file
    850 
    -      cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db
    851 
    -      pure new_db
    852 
    -    Just db ->
    853 
    -      pure db
    854 
    -
    855 
    --- | Read the 'UnitDatabase' at the given location.
    856 
    -readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
    857 
    -readUnitDatabase logger cfg conf_file = do
    858 
    -  isdir <- OsPath.doesDirectoryExist conf_file
    859 
    -
    860 
    -  proto_pkg_configs <-
    861 
    -    if isdir
    862 
    -       then readDirStyleUnitInfo conf_file
    863 
    -       else do
    864 
    -            isfile <- OsPath.doesFileExist conf_file
    865 
    -            if isfile
    866 
    -               then do
    867 
    -                 mpkgs <- tryReadOldFileStyleUnitInfo
    868 
    -                 case mpkgs of
    869 
    -                   Just pkgs -> return pkgs
    870 
    -                   Nothing   -> throwGhcExceptionIO $ InstallationError $
    871 
    -                      "ghc no longer supports single-file style package " ++
    872 
    -                      "databases (" ++ show conf_file ++
    873 
    -                      ") use 'ghc-pkg init' to create the database with " ++
    874 
    -                      "the correct format."
    875 
    -               else throwGhcExceptionIO $ InstallationError $
    876 
    -                      "can't find a package database at " ++ show conf_file
    877 
    -
    878 
    -  let
    879 
    -      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
    880 
    -      conf_file' = OsPath.dropTrailingPathSeparator conf_file
    881 
    -      top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg)
    882 
    -      pkgroot = OsPath.takeDirectory conf_file'
    883 
    -      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
    884 
    -                         proto_pkg_configs
    885 
    -  --
    886 
    -  pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1
    887 
    -  return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2
    888 
    -  where
    889 
    -    readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
    890 
    -    readDirStyleUnitInfo conf_dir = do
    891 
    -      let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache")
    892 
    -      cache_exists <- OsPath.doesFileExist filename
    893 
    -      if cache_exists
    894 
    -        then do
    895 
    -          debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename
    896 
    -          readPackageDbForGhc filename
    897 
    -        else do
    898 
    -          -- If there is no package.cache file, we check if the database is not
    899 
    -          -- empty by inspecting if the directory contains any .conf file. If it
    900 
    -          -- does, something is wrong and we fail. Otherwise we assume that the
    901 
    -          -- database is empty.
    902 
    -          debugTraceMsg logger 2 $ text "There is no package.cache in"
    903 
    -                      <+> ppr conf_dir
    904 
    -                       <> text ", checking if the database is empty"
    905 
    -          db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))
    906 
    -                   <$> OsPath.getDirectoryContents conf_dir
    907 
    -          if db_empty
    908 
    -            then do
    909 
    -              debugTraceMsg logger 3 $ text "There are no .conf files in"
    910 
    -                          <+> ppr conf_dir <> text ", treating"
    911 
    -                          <+> text "package database as empty"
    912 
    -              return []
    913 
    -            else
    914 
    -              throwGhcExceptionIO $ InstallationError $
    915 
    -                "there is no package.cache in " ++ show conf_dir ++
    916 
    -                " even though package database is not empty"
    917 
    -
    918 
    -
    919 
    -    -- Single-file style package dbs have been deprecated for some time, but
    920 
    -    -- it turns out that Cabal was using them in one place. So this is a
    921 
    -    -- workaround to allow older Cabal versions to use this newer ghc.
    922 
    -    -- We check if the file db contains just "[]" and if so, we look for a new
    923 
    -    -- dir-style db in conf_file.d/, ie in a dir next to the given file.
    924 
    -    -- We cannot just replace the file with a new dir style since Cabal still
    925 
    -    -- assumes it's a file and tries to overwrite with 'writeFile'.
    926 
    -    -- ghc-pkg also cooperates with this workaround.
    927 
    -    tryReadOldFileStyleUnitInfo = do
    928 
    -      content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""
    929 
    -      if take 2 content == "[]"
    930 
    -        then do
    931 
    -          let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"
    932 
    -          direxists <- OsPath.doesDirectoryExist conf_dir
    933 
    -          if direxists
    934 
    -             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir)
    935 
    -                     liftM Just (readDirStyleUnitInfo conf_dir)
    936 
    -             else return (Just []) -- ghc-pkg will create it when it's updated
    937 
    -        else return Nothing
    938 
    -
    939 
    -mungeUnitInfo :: OsPath -> OsPath
    940 
    -                   -> UnitInfo -> UnitInfo
    941 
    -mungeUnitInfo top_dir pkgroot =
    942 
    -    mungeBytecodeLibFields
    943 
    -  . mungeLibDirFields
    944 
    -  . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))
    945 
    -
    946 
    -mungeLibDirFields :: UnitInfo -> UnitInfo
    947 
    -mungeLibDirFields pkg =
    948 
    -    pkg {
    949 
    -      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
    950 
    -         [] -> unitLibraryDirs pkg
    951 
    -         ds -> ds
    952 
    -      , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of
    953 
    -         [] -> unitLibraryDirs pkg
    954 
    -         ds -> ds
    955 
    -    }
    956 
    -
    957 
    --- | Default to using library-dirs if bytecode library dirs is not explicitly set.
    958 
    -mungeBytecodeLibFields :: UnitInfo -> UnitInfo
    959 
    -mungeBytecodeLibFields pkg =
    960 
    -    pkg {
    961 
    -      unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of
    962 
    -         [] -> unitLibraryDirs pkg
    963 
    -         ds -> ds
    964 
    -    }
    965 
    -
    966 
    -seqUnitInfo :: UnitInfo -> b -> b
    967 
    -seqUnitInfo ui b =
    968 
    -  unitImportDirs ui `seqList`
    969 
    -  unitIncludeDirs ui `seqList`
    970 
    -  unitLibraryDirs ui `seqList`
    971 
    -  unitLibraryBytecodeDirs ui `seqList`
    972 
    -  unitExtDepFrameworkDirs ui `seq`
    973 
    -  unitHaddockInterfaces ui `seq`
    974 
    -  unitHaddockHTMLs ui `seqList`
    975 
    -  unitLibraryDynDirs ui `seqList`
    976 
    -  unitLibraryDirsStatic ui `seqList`
    977 
    -  unitDepends ui `seqList`
    978 
    -  unitExposedModules ui `seqList`
    979 
    -  b
    980 
    -
    981 
    -evaluateUnitInfo :: UnitInfo -> IO UnitInfo
    982 
    -evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui)
    983 
    -
    984 515 
     -- -----------------------------------------------------------------------------
    985 516 
     -- Modify our copy of the unit database based on trust flags,
    986 517 
     -- -trust and -distrust.
    ... ... @@ -1094,265 +625,6 @@ applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag =
    1094 625 
              Left ps  -> Failed (PackageFlagErr flag ps)
    1095 626 
              Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps)
    1096 627
    1097 
    --- | Like 'selectPackages', but doesn't return a list of unmatched
    1098 
    --- packages.  Furthermore, any packages it returns are *renamed*
    1099 
    --- if the 'UnitArg' has a renaming associated with it.
    1100 
    -findPackages :: UnitPrecedenceMap
    1101 
    -             -> UnitInfoMap
    1102 
    -             -> PackageArg -> [UnitInfo]
    1103 
    -             -> UnusableUnits
    1104 
    -             -> Either [(UnitInfo, UnusableUnitReason)]
    1105 
    -                [UnitInfo]
    1106 
    -findPackages prec_map pkg_map arg pkgs unusable
    1107 
    -  = let ps = mapMaybe (finder arg) pkgs
    1108 
    -    in if null ps
    1109 
    -        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
    1110 
    -                            (nonDetEltsUniqMap unusable))
    1111 
    -        else Right (sortByPreference prec_map ps)
    1112 
    -  where
    1113 
    -    finder (PackageArg str) p
    1114 
    -      = if matchingStr str p
    1115 
    -          then Just p
    1116 
    -          else Nothing
    1117 
    -    finder (UnitIdArg uid) p
    1118 
    -      = case uid of
    1119 
    -          RealUnit (Definite iuid)
    1120 
    -            | iuid == unitId p
    1121 
    -            -> Just p
    1122 
    -          VirtUnit inst
    1123 
    -            | instUnitInstanceOf inst == unitId p
    1124 
    -            -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p)
    1125 
    -          _ -> Nothing
    1126 
    -
    1127 
    -selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
    1128 
    -               -> UnusableUnits
    1129 
    -               -> Either [(UnitInfo, UnusableUnitReason)]
    1130 
    -                  ([UnitInfo], [UnitInfo])
    1131 
    -selectPackages prec_map arg pkgs unusable
    1132 
    -  = let matches = matching arg
    1133 
    -        (ps,rest) = partition matches pkgs
    1134 
    -    in if null ps
    1135 
    -        then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
    1136 
    -        else Right (sortByPreference prec_map ps, rest)
    1137 
    -
    1138 
    --- | Rename a 'UnitInfo' according to some module instantiation.
    1139 
    -renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
    1140 
    -renameUnitInfo pkg_map insts conf =
    1141 
    -    let hsubst = listToUFM insts
    1142 
    -        smod  = renameHoleModule' pkg_map hsubst
    1143 
    -        new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf)
    1144 
    -    in conf {
    1145 
    -        unitInstantiations = new_insts,
    1146 
    -        unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
    1147 
    -                             (unitExposedModules conf)
    1148 
    -    }
    1149 
    -
    1150 
    -
    1151 
    --- A package named on the command line can either include the
    1152 
    --- version, or just the name if it is unambiguous.
    1153 
    -matchingStr :: String -> UnitInfo -> Bool
    1154 
    -matchingStr str p
    1155 
    -        =  str == unitPackageIdString p
    1156 
    -        || str == unitPackageNameString p
    1157 
    -
    1158 
    -matchingId :: UnitId -> UnitInfo -> Bool
    1159 
    -matchingId uid p = uid == unitId p
    1160 
    -
    1161 
    -matching :: PackageArg -> UnitInfo -> Bool
    1162 
    -matching (PackageArg str) = matchingStr str
    1163 
    -matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid
    1164 
    -matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
    1165 
    -
    1166 
    --- | This sorts a list of packages, putting "preferred" packages first.
    1167 
    --- See 'compareByPreference' for the semantics of "preference".
    1168 
    -sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
    1169 
    -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))
    1170 
    -
    1171 
    --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
    1172 
    --- which should be "active".  Here is the order of preference:
    1173 
    ---
    1174 
    ---      1. First, prefer the latest version
    1175 
    ---      2. If the versions are the same, prefer the package that
    1176 
    ---      came in the latest package database.
    1177 
    ---
    1178 
    --- Pursuant to #12518, we could change this policy to, for example, remove
    1179 
    --- the version preference, meaning that we would always prefer the units
    1180 
    --- in later unit database.
    1181 
    -compareByPreference
    1182 
    -    :: UnitPrecedenceMap
    1183 
    -    -> UnitInfo
    1184 
    -    -> UnitInfo
    1185 
    -    -> Ordering
    1186 
    -compareByPreference prec_map pkg pkg'
    1187 
    -  = case comparing unitPackageVersion pkg pkg' of
    1188 
    -        GT -> GT
    1189 
    -        EQ | Just prec  <- lookupUniqMap prec_map (unitId pkg)
    1190 
    -           , Just prec' <- lookupUniqMap prec_map (unitId pkg')
    1191 
    -           -- Prefer the unit from the later DB flag (i.e., higher
    1192 
    -           -- precedence)
    1193 
    -           -> compare prec prec'
    1194 
    -           | otherwise
    1195 
    -           -> EQ
    1196 
    -        LT -> LT
    1197 
    -
    1198 
    -comparing :: Ord a => (t -> a) -> t -> t -> Ordering
    1199 
    -comparing f a b = f a `compare` f b
    1200 
    -
    1201 
    -pprFlag :: PackageFlag -> SDoc
    1202 
    -pprFlag flag = case flag of
    1203 
    -    HidePackage p   -> text "-hide-package " <> text p
    1204 
    -    ExposePackage doc _ _ -> text doc
    1205 
    -
    1206 
    -pprTrustFlag :: TrustFlag -> SDoc
    1207 
    -pprTrustFlag flag = case flag of
    1208 
    -    TrustPackage p    -> text "-trust " <> text p
    1209 
    -    DistrustPackage p -> text "-distrust " <> text p
    1210 
    -
    1211 
    --- -----------------------------------------------------------------------------
    1212 
    --- Wired-in units
    1213 
    ---
    1214 
    --- See Note [Wired-in units] in GHC.Unit.Types
    1215 
    -
    1216 
    -type WiringMap = UniqMap UnitId UnitId
    1217 
    -type UnwiringMap = UniqMap UnitId UnitId
    1218 
    -
    1219 
    -findWiredInUnits
    1220 
    -   :: Logger
    1221 
    -   -> UnitPrecedenceMap
    1222 
    -   -> [UnitInfo]           -- database
    1223 
    -   -> VisibilityMap             -- info on what units are visible
    1224 
    -                                -- for wired in selection
    1225 
    -   -> IO WiringMap   -- map from unit id to wired identity
    1226 
    -findWiredInUnits logger prec_map pkgs vis_map = do
    1227 
    -  -- Now we must find our wired-in units, and rename them to
    1228 
    -  -- their canonical names (eg. base-1.0 ==> base), as described
    1229 
    -  -- in Note [Wired-in units] in GHC.Unit.Types
    1230 
    -  let
    1231 
    -        matches :: UnitInfo -> UnitId -> Bool
    1232 
    -        pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
    1233 
    -
    1234 
    -        -- find which package corresponds to each wired-in package
    1235 
    -        -- delete any other packages with the same name
    1236 
    -        -- update the package and any dependencies to point to the new
    1237 
    -        -- one.
    1238 
    -        --
    1239 
    -        -- When choosing which package to map to a wired-in package
    1240 
    -        -- name, we try to pick the latest version of exposed packages.
    1241 
    -        -- However, if there are no exposed wired in packages available
    1242 
    -        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
    1243 
    -        -- to assign a package for the wired-in package: so we try again
    1244 
    -        -- with hidden packages included to (and pick the latest
    1245 
    -        -- version).
    1246 
    -        --
    1247 
    -        -- You can also override the default choice by using -ignore-package:
    1248 
    -        -- this works even when there is no exposed wired in package
    1249 
    -        -- available.
    1250 
    -        --
    1251 
    -        findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
    1252 
    -        findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound]
    1253 
    -          where
    1254 
    -                all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
    1255 
    -                all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ]
    1256 
    -
    1257 
    -                try ps = case sortByPreference prec_map ps of
    1258 
    -                    p:_ -> Just <$> pick p
    1259 
    -                    _ -> pure Nothing
    1260 
    -
    1261 
    -                notfound = do
    1262 
    -                          debugTraceMsg logger 2 $
    1263 
    -                            text "wired-in package "
    1264 
    -                                 <> ftext (unitIdFS wired_pkg)
    1265 
    -                                 <> text " not found."
    1266 
    -                          return Nothing
    1267 
    -                pick :: UnitInfo -> IO (UnitId, UnitInfo)
    1268 
    -                pick pkg = do
    1269 
    -                        debugTraceMsg logger 2 $
    1270 
    -                            text "wired-in package "
    1271 
    -                                 <> ftext (unitIdFS wired_pkg)
    1272 
    -                                 <> text " mapped to "
    1273 
    -                                 <> ppr (unitId pkg)
    1274 
    -                        return (wired_pkg, pkg)
    1275 
    -
    1276 
    -
    1277 
    -  mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds
    1278 
    -  let
    1279 
    -        wired_in_pkgs = catMaybes mb_wired_in_pkgs
    1280 
    -
    1281 
    -        wiredInMap :: UniqMap UnitId UnitId
    1282 
    -        wiredInMap = listToUniqMap
    1283 
    -          [ (unitId realUnitInfo, wiredInUnitId)
    1284 
    -          | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
    1285 
    -          , not (unitIsIndefinite realUnitInfo)
    1286 
    -          ]
    1287 
    -
    1288 
    -  return wiredInMap
    1289 
    -
    1290 
    -updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
    1291 
    -updateWiredInUnits wiredInMap knownInfos pkgs =
    1292 
    -  map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs
    1293 
    -
    1294 
    -updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
    1295 
    -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg =
    1296 
    -  let
    1297 
    -    upd_wired_in_pkg wiredInUnitId pkg =
    1298 
    -      pkg { unitId         = wiredInUnitId
    1299 
    -          , unitInstanceOf = wiredInUnitId
    1300 
    -              -- every non instantiated unit is an instance of
    1301 
    -              -- itself (required by Backpack...)
    1302 
    -              --
    1303 
    -              -- See Note [About units] in GHC.Unit
    1304 
    -          }
    1305 
    -
    1306 
    -    upd_deps pkg = pkg {
    1307 
    -          unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
    1308 
    -          unitExposedModules
    1309 
    -            = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
    1310 
    -                  (unitExposedModules pkg)
    1311 
    -        }
    1312 
    -  in
    1313 
    -    case lookupUniqMap wiredInMap (unitId pkg) of
    1314 
    -      Just wiredIn ->
    1315 
    -        case lookupGlobalUnitInfoMap (GlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of
    1316 
    -          Just ui ->
    1317 
    -            Right ui
    1318 
    -          Nothing ->
    1319 
    -            let
    1320 
    -              updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg
    1321 
    -            in
    1322 
    -              Left $ seqUnitInfo updated_pkg updated_pkg
    1323 
    -      Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of
    1324 
    -        Just ui ->
    1325 
    -          Right ui
    1326 
    -        Nothing ->
    1327 
    -          let
    1328 
    -            updated_pkg = upd_deps pkg
    1329 
    -          in
    1330 
    -            Left $ seqUnitInfo updated_pkg updated_pkg
    1331 
    -
    1332 
    --- Helper functions for rewiring Module and Unit.  These
    1333 
    --- rewrite Units of modules in wired-in packages to the form known to the
    1334 
    --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types.
    1335 
    ---
    1336 
    --- For instance, base-4.9.0.0 will be rewritten to just base, to match
    1337 
    --- what appears in GHC.Builtin.Names.
    1338 
    -
    1339 
    -upd_wired_in_mod :: WiringMap -> Module -> Module
    1340 
    -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
    1341 
    -
    1342 
    -upd_wired_in_uid :: WiringMap -> Unit -> Unit
    1343 
    -upd_wired_in_uid wiredInMap u = case u of
    1344 
    -   HoleUnit -> HoleUnit
    1345 
    -   RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))
    1346 
    -   VirtUnit indef_uid ->
    1347 
    -      VirtUnit $ mkInstantiatedUnit
    1348 
    -        (instUnitInstanceOf indef_uid)
    1349 
    -        (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid))
    1350 
    -
    1351 
    -upd_wired_in :: WiringMap -> UnitId -> UnitId
    1352 
    -upd_wired_in wiredInMap key
    1353 
    -    | Just key' <- lookupUniqMap wiredInMap key = key'
    1354 
    -    | otherwise = key
    1355 
    -
    1356 628 
     updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
    1357 629 
     updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap)
    1358 630 
       where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of
    ... ... @@ -1362,51 +634,6 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList w
    1362 634
    1363 635 
       -- ----------------------------------------------------------------------------
    1364 636
    1365 
    --- | The reason why a unit is unusable.
    1366 
    -data UnusableUnitReason
    1367 
    -  = -- | We ignored it explicitly using @-ignore-package@.
    1368 
    -    IgnoredWithFlag
    1369 
    -    -- | This unit transitively depends on a unit that was never present
    1370 
    -    -- in any of the provided databases.
    1371 
    -  | BrokenDependencies   [UnitId]
    1372 
    -    -- | This unit transitively depends on a unit involved in a cycle.
    1373 
    -    -- Note that the list of 'UnitId' reports the direct dependencies
    1374 
    -    -- of this unit that (transitively) depended on the cycle, and not
    1375 
    -    -- the actual cycle itself (which we report separately at high verbosity.)
    1376 
    -  | CyclicDependencies   [UnitId]
    1377 
    -    -- | This unit transitively depends on a unit which was ignored.
    1378 
    -  | IgnoredDependencies  [UnitId]
    1379 
    -    -- | This unit transitively depends on a unit which was
    1380 
    -    -- shadowed by an ABI-incompatible unit.
    1381 
    -  | ShadowedDependencies [UnitId]
    1382 
    -
    1383 
    -instance Outputable UnusableUnitReason where
    1384 
    -    ppr IgnoredWithFlag = text "[ignored with flag]"
    1385 
    -    ppr (BrokenDependencies uids)   = brackets (text "broken" <+> ppr uids)
    1386 
    -    ppr (CyclicDependencies uids)   = brackets (text "cyclic" <+> ppr uids)
    1387 
    -    ppr (IgnoredDependencies uids)  = brackets (text "ignored" <+> ppr uids)
    1388 
    -    ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids)
    1389 
    -
    1390 
    -type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)
    1391 
    -
    1392 
    -pprReason :: SDoc -> UnusableUnitReason -> SDoc
    1393 
    -pprReason pref reason = case reason of
    1394 
    -  IgnoredWithFlag ->
    1395 
    -      pref <+> text "ignored due to an -ignore-package flag"
    1396 
    -  BrokenDependencies deps ->
    1397 
    -      pref <+> text "unusable due to missing dependencies:" $$
    1398 
    -        nest 2 (hsep (map ppr deps))
    1399 
    -  CyclicDependencies deps ->
    1400 
    -      pref <+> text "unusable due to cyclic dependencies:" $$
    1401 
    -        nest 2 (hsep (map ppr deps))
    1402 
    -  IgnoredDependencies deps ->
    1403 
    -      pref <+> text ("unusable because the -ignore-package flag was used to " ++
    1404 
    -                     "ignore at least one of its dependencies:") $$
    1405 
    -        nest 2 (hsep (map ppr deps))
    1406 
    -  ShadowedDependencies deps ->
    1407 
    -      pref <+> text "unusable due to shadowed dependencies:" $$
    1408 
    -        nest 2 (hsep (map ppr deps))
    1409 
    -
    1410 637 
     reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
    1411 638 
     reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs
    1412 639 
       where
    ... ... @@ -1416,193 +643,6 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs
    1416 643 
               text "these packages are involved in a cycle:" $$
    1417 644 
                 nest 2 (hsep (map (ppr . unitId) vs))
    1418 645
    1419 
    -reportUnusable :: Logger -> UnusableUnits -> IO ()
    1420 
    -reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs)
    1421 
    -  where
    1422 
    -    report (ipid, (_, reason)) =
    1423 
    -       debugTraceMsg logger 2 $
    1424 
    -         pprReason
    1425 
    -           (text "package" <+> ppr ipid <+> text "is") reason
    1426 
    -
    1427 
    --- ----------------------------------------------------------------------------
    1428 
    ---
    1429 
    --- Utilities on the database
    1430 
    ---
    1431 
    -
    1432 
    --- | A reverse dependency index, mapping an 'UnitId' to
    1433 
    --- the 'UnitId's which have a dependency on it.
    1434 
    -type RevIndex = UniqMap UnitId [UnitId]
    1435 
    -
    1436 
    --- | Compute the reverse dependency index of a unit database.
    1437 
    -reverseDeps :: UnitInfoMap -> RevIndex
    1438 
    -reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db
    1439 
    -  where
    1440 
    -    go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
    1441 
    -    go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg)
    1442 
    -    go' from r to = addToUniqMap_C (++) r to [from]
    1443 
    -
    1444 
    --- | Given a list of 'UnitId's to remove, a database,
    1445 
    --- and a reverse dependency index (as computed by 'reverseDeps'),
    1446 
    --- remove those units, plus any units which depend on them.
    1447 
    --- Returns the pruned database, as well as a list of 'UnitInfo's
    1448 
    --- that was removed.
    1449 
    -removeUnits :: [UnitId] -> RevIndex
    1450 
    -               -> UnitInfoMap
    1451 
    -               -> (UnitInfoMap, [UnitInfo])
    1452 
    -removeUnits uids index m = go uids (m,[])
    1453 
    -  where
    1454 
    -    go [] (m,pkgs) = (m,pkgs)
    1455 
    -    go (uid:uids) (m,pkgs)
    1456 
    -        | Just pkg <- lookupUniqMap m uid
    1457 
    -        = case lookupUniqMap index uid of
    1458 
    -            Nothing    -> go uids (delFromUniqMap m uid, pkg:pkgs)
    1459 
    -            Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs)
    1460 
    -        | otherwise
    1461 
    -        = go uids (m,pkgs)
    1462 
    -
    1463 
    --- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'
    1464 
    --- which correspond to units that do not exist in the index.
    1465 
    -depsNotAvailable :: UnitInfoMap
    1466 
    -                 -> UnitInfo
    1467 
    -                 -> [UnitId]
    1468 
    -depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg)
    1469 
    -
    1470 
    --- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
    1471 
    --- 'unitAbiDepends' which correspond to units that do not exist, OR have
    1472 
    --- mismatching ABIs.
    1473 
    -depsAbiMismatch :: UnitInfoMap
    1474 
    -                -> UnitInfo
    1475 
    -                -> [UnitId]
    1476 
    -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg
    1477 
    -  where
    1478 
    -    abiMatch (dep_uid, abi)
    1479 
    -        | Just dep_pkg <- lookupUniqMap pkg_map dep_uid
    1480 
    -        = unitAbiHash dep_pkg == abi
    1481 
    -        | otherwise
    1482 
    -        = False
    1483 
    -
    1484 
    --- -----------------------------------------------------------------------------
    1485 
    --- Ignore units
    1486 
    -
    1487 
    -ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
    1488 
    -ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags)
    1489 
    -  where
    1490 
    -  doit (IgnorePackage str) =
    1491 
    -     case partition (matchingStr str) pkgs of
    1492 
    -         (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
    1493 
    -                    | p <- ps ]
    1494 
    -        -- missing unit is not an error for -ignore-package,
    1495 
    -        -- because a common usage is to -ignore-package P as
    1496 
    -        -- a preventative measure just in case P exists.
    1497 
    -
    1498 
    --- ----------------------------------------------------------------------------
    1499 
    ---
    1500 
    --- Merging databases
    1501 
    ---
    1502 
    -
    1503 
    --- | For each unit, a mapping from uid -> i indicates that this
    1504 
    --- unit was brought into GHC by the ith @-package-db@ flag on
    1505 
    --- the command line.  We use this mapping to make sure we prefer
    1506 
    --- units that were defined later on the command line, if there
    1507 
    --- is an ambiguity.
    1508 
    -type UnitPrecedenceMap = UniqMap UnitId Int
    1509 
    -
    1510 
    --- | Given a list of databases, merge them together, where
    1511 
    --- units with the same unit id in later databases override
    1512 
    --- earlier ones.  This does NOT check if the resulting database
    1513 
    --- makes sense (that's done by 'validateDatabase').
    1514 
    -mergeDatabases :: Logger -> [UnitDatabase UnitId]
    1515 
    -               -> IO (UnitInfoMap, UnitPrecedenceMap)
    1516 
    -mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
    1517 
    -  where
    1518 
    -    merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
    1519 
    -      debugTraceMsg logger 2 $
    1520 
    -          text "loading package database" <+> ppr db_path
    1521 
    -      when (logVerbAtLeast logger 2) $
    1522 
    -        forM_ (Set.toList override_set) $ \pkg ->
    1523 
    -            debugTraceMsg logger 2 $
    1524 
    -                text "package" <+> ppr pkg <+>
    1525 
    -                text "overrides a previously defined package"
    1526 
    -      return (pkg_map', prec_map')
    1527 
    -     where
    1528 
    -      db_map = mk_pkg_map db
    1529 
    -      mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p))
    1530 
    -
    1531 
    -      -- The set of UnitIds which appear in both db and pkgs.  These are the
    1532 
    -      -- ones that get overridden.  Compute this just to give some
    1533 
    -      -- helpful debug messages at -v2
    1534 
    -      override_set :: Set UnitId
    1535 
    -      override_set = Set.intersection (nonDetUniqMapToKeySet db_map)
    1536 
    -                                      (nonDetUniqMapToKeySet pkg_map)
    1537 
    -
    1538 
    -      -- Now merge the sets together (NB: in case of duplicate,
    1539 
    -      -- first argument preferred)
    1540 
    -      pkg_map' :: UnitInfoMap
    1541 
    -      pkg_map' = pkg_map `plusUniqMap` db_map
    1542 
    -
    1543 
    -      prec_map' :: UnitPrecedenceMap
    1544 
    -      prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map)
    1545 
    -
    1546 
    --- | Validates a database, removing unusable units from it
    1547 
    --- (this includes removing units that the user has explicitly
    1548 
    --- ignored.)  Our general strategy:
    1549 
    ---
    1550 
    --- 1. Remove all broken units (dangling dependencies)
    1551 
    --- 2. Remove all units that are cyclic
    1552 
    --- 3. Apply ignore flags
    1553 
    --- 4. Remove all units which have deps with mismatching ABIs
    1554 
    ---
    1555 
    -validateDatabase :: UnitConfig -> UnitInfoMap
    1556 
    -                 -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
    1557 
    -validateDatabase cfg pkg_map1 =
    1558 
    -    (pkg_map5, unusable, sccs)
    1559 
    -  where
    1560 
    -    ignore_flags = reverse (unitConfigFlagsIgnored cfg)
    1561 
    -
    1562 
    -    -- Compute the reverse dependency index
    1563 
    -    index = reverseDeps pkg_map1
    1564 
    -
    1565 
    -    -- Helper function
    1566 
    -    mk_unusable mk_err dep_matcher m uids =
    1567 
    -      listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))
    1568 
    -                    | pkg <- uids
    1569 
    -                    ]
    1570 
    -
    1571 
    -    -- Find broken units
    1572 
    -    directly_broken = filter (not . null . depsNotAvailable pkg_map1)
    1573 
    -                             (nonDetEltsUniqMap pkg_map1)
    1574 
    -    (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1
    1575 
    -    unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken
    1576 
    -
    1577 
    -    -- Find recursive units
    1578 
    -    sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)
    1579 
    -                            | pkg <- nonDetEltsUniqMap pkg_map2 ]
    1580 
    -    getCyclicSCC (CyclicSCC vs) = map unitId vs
    1581 
    -    getCyclicSCC (AcyclicSCC _) = []
    1582 
    -    (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2
    1583 
    -    unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic
    1584 
    -
    1585 
    -    -- Apply ignore flags
    1586 
    -    directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3)
    1587 
    -    (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3
    1588 
    -    unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored
    1589 
    -
    1590 
    -    -- Knock out units whose dependencies don't agree with ABI
    1591 
    -    -- (i.e., got invalidated due to shadowing)
    1592 
    -    directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)
    1593 
    -                               (nonDetEltsUniqMap pkg_map4)
    1594 
    -    (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4
    1595 
    -    unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed
    1596 
    -
    1597 
    -    -- combine all unusables. The order is important for shadowing.
    1598 
    -    -- plusUniqMapList folds using plusUFM which is right biased (opposite of
    1599 
    -    -- Data.Map.union) so the head of the list should be the least preferred
    1600 
    -    unusable = plusUniqMapList [ unusable_shadowed
    1601 
    -                               , unusable_cyclic
    1602 
    -                               , unusable_broken
    1603 
    -                               , unusable_ignored
    1604 
    -                               , directly_ignored
    1605 
    -                               ]
    1606 646
    1607 647 
     -- -----------------------------------------------------------------------------
    1608 648 
     -- When all the command-line options are in, we can process our unit
    ... ... @@ -1667,7 +707,7 @@ mkUnitState logger unit_index cfg = do
    1667 707 
               we build a mapping saying what every in scope module name points to.
    1668 708 
     -}
    1669 709
    1670 
    -  raw_dbs <- readUnitDatabases logger cfg
    710 
    +  raw_dbs <- readUnitDatabases logger (initUnitDbConfig cfg)
    1671 711
    1672 712 
       -- distrust all units if the flag is set
    1673 713 
       let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db)
    ... ... @@ -1697,7 +737,7 @@ mkUnitState logger unit_index cfg = do
    1697 737
    1698 738 
       -- Now that we've merged everything together, prune out unusable
    1699 739 
       -- packages.
    1700 
    -  let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
    740 
    +  let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1
    1701 741
    1702 742 
       reportCycles   logger sccs
    1703 743 
       reportUnusable logger unusable
    ... ... @@ -1781,9 +821,9 @@ mkUnitState logger unit_index cfg = do
    1781 821 
             modifyIORef' unit_index (setWireMap wmap)
    1782 822 
             pure wmap
    1783 823 
           else do
    1784 
    -        pure $ ui_wireMap ui
    824 
    +        pure $ wiringMap ui
    1785 825
    1786 
    -    let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1
    826 
    +    let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1
    1787 827 
             (new_pkgs, _pkgs_set) = partitionEithers all_pkgs
    1788 828 
         modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs)
    1789 829 
         pure (wireMap, map (either id id) all_pkgs)
    ... ... @@ -1859,7 +899,7 @@ mkUnitState logger unit_index cfg = do
    1859 899 
                         $ closeUnitDeps pkg_db
    1860 900 
                         $ zip (map toUnitId preload3) (repeat Nothing)
    1861 901
    1862 
    -  let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map
    902 
    +  let mod_map1 = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db vis_map
    1863 903 
           mod_map2 = mkUnusableModuleNameProvidersMap unusable
    1864 904 
           mod_map = mod_map2 `plusUniqMap` mod_map1
    1865 905
    ... ... @@ -1872,15 +912,24 @@ mkUnitState logger unit_index cfg = do
    1872 912 
              , trustedUnits                 = trusted
    1873 913 
              , distrustedUnits              = distrusted
    1874 914 
              , moduleNameProvidersMap       = mod_map
    1875 
    -         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map
    915 
    +         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db plugin_vis_map
    1876 916 
              , packageNameMap               = pkgname_map
    1877 
    -        --  , wireMap                      = wired_map
    1878 
    -        --  , unwireMap                    = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    1879 917 
              , requirementContext           = req_ctx
    1880 918 
              , allowVirtualUnits            = unitConfigAllowVirtual cfg
    1881 919 
              }
    1882 920 
       return state
    1883 921
    922 
    +initUnitDbConfig :: UnitConfig -> UnitDbConfig
    923 
    +initUnitDbConfig uc = UnitDbConfig
    924 
    +  { unitDbConfigFlagsDB = unitConfigFlagsDB uc
    925 
    +  , unitDbConfigProgramName = unitConfigProgramName uc
    926 
    +  , unitDbConfigDBName = unitConfigDBName uc
    927 
    +  , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc
    928 
    +  , unitDbConfigGlobalDB = unitConfigGlobalDB uc
    929 
    +  , unitDbConfigGHCDir = unitConfigGHCDir uc
    930 
    +  , unitDbConfigDBCache = unitConfigDBCache uc
    931 
    +  }
    932 
    +
    1884 933 
     selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
    1885 934 
     selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True
    1886 935 
     selectHptFlag _ _ = False
    ... ... @@ -1893,158 +942,6 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags
    1893 942 
         -- MP: This does not yet support thinning/renaming
    1894 943 
         go cur _ = cur
    1895 944
    1896 
    -
    1897 
    --- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
    1898 
    --- that it was recorded as in the package database.
    1899 
    -unwireUnit :: UnitIndex -> Unit -> Unit
    1900 
    -unwireUnit state uid@(RealUnit (Definite def_uid)) =
    1901 
    -    maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid)
    1902 
    -unwireUnit _ uid = uid
    1903 
    -
    1904 
    --- -----------------------------------------------------------------------------
    1905 
    --- | Makes the mapping from ModuleName to package info
    1906 
    -
    1907 
    --- Slight irritation: we proceed by leafing through everything
    1908 
    --- in the installed package database, which makes handling indefinite
    1909 
    --- packages a bit bothersome.
    1910 
    -
    1911 
    -mkModuleNameProvidersMap
    1912 
    -  :: Logger
    1913 
    -  -> UnitConfig
    1914 
    -  -> UnitInfoMap
    1915 
    -  -> VisibilityMap
    1916 
    -  -> ModuleNameProvidersMap
    1917 
    -mkModuleNameProvidersMap logger cfg pkg_map vis_map =
    1918 
    -    -- What should we fold on?  Both situations are awkward:
    1919 
    -    --
    1920 
    -    --    * Folding on the visibility map means that we won't create
    1921 
    -    --      entries for packages that aren't mentioned in vis_map
    1922 
    -    --      (e.g., hidden packages, causing #14717)
    1923 
    -    --
    1924 
    -    --    * Folding on pkg_map is awkward because if we have an
    1925 
    -    --      Backpack instantiation, we need to possibly add a
    1926 
    -    --      package from pkg_map multiple times to the actual
    1927 
    -    --      ModuleNameProvidersMap.  Also, we don't really want
    1928 
    -    --      definite package instantiations to show up in the
    1929 
    -    --      list of possibilities.
    1930 
    -    --
    1931 
    -    -- So what will we do instead?  We'll extend vis_map with
    1932 
    -    -- entries for every definite (for non-Backpack) and
    1933 
    -    -- indefinite (for Backpack) package, so that we get the
    1934 
    -    -- hidden entries we need.
    1935 
    -    nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended
    1936 
    - where
    1937 
    -  vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map
    1938 
    -
    1939 
    -  default_vis = listToUniqMap
    1940 
    -                  [ (mkUnit pkg, mempty)
    1941 
    -                  | (_, pkg) <- nonDetUniqMapToList pkg_map
    1942 
    -                  -- Exclude specific instantiations of an indefinite
    1943 
    -                  -- package
    1944 
    -                  , unitIsIndefinite pkg || null (unitInstantiations pkg)
    1945 
    -                  ]
    1946 
    -
    1947 
    -  emptyMap = emptyUniqMap
    1948 
    -  setOrigins m os = fmap (const os) m
    1949 
    -  extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap
    1950 
    -    = addListTo modmap theBindings
    1951 
    -   where
    1952 
    -    pkg = unit_lookup uid
    1953 
    -
    1954 
    -    theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
    1955 
    -    theBindings = newBindings b rns
    1956 
    -
    1957 
    -    newBindings :: Bool
    1958 
    -                -> [(ModuleName, ModuleName)]
    1959 
    -                -> [(ModuleName, UniqMap Module ModuleOrigin)]
    1960 
    -    newBindings e rns  = es e ++ hiddens ++ map rnBinding rns
    1961 
    -
    1962 
    -    rnBinding :: (ModuleName, ModuleName)
    1963 
    -              -> (ModuleName, UniqMap Module ModuleOrigin)
    1964 
    -    rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
    1965 
    -     where origEntry = case lookupUFM esmap orig of
    1966 
    -            Just r -> r
    1967 
    -            Nothing -> throwGhcException (CmdLineError (renderWithContext
    1968 
    -                        (log_default_user_context (logFlags logger))
    1969 
    -                        (text "package flag: could not find module name" <+>
    1970 
    -                            ppr orig <+> text "in package" <+> ppr pk)))
    1971 
    -
    1972 
    -    es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
    1973 
    -    es e = do
    1974 
    -     (m, exposedReexport) <- exposed_mods
    1975 
    -     let (pk', m', origin') =
    1976 
    -          case exposedReexport of
    1977 
    -           Nothing -> (pk, m, fromExposedModules e)
    1978 
    -           Just (Module pk' m') ->
    1979 
    -              (pk', m', fromReexportedModules e pkg)
    1980 
    -     return (m, mkModMap pk' m' origin')
    1981 
    -
    1982 
    -    esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin)
    1983 
    -    esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
    1984 
    -                                 -- be overwritten
    1985 
    -
    1986 
    -    hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
    1987 
    -
    1988 
    -    pk = mkUnit pkg
    1989 
    -    unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid
    1990 
    -                        `orElse` pprPanic "unit_lookup" (ppr uid)
    1991 
    -
    1992 
    -    exposed_mods = unitExposedModules pkg
    1993 
    -    hidden_mods  = unitHiddenModules pkg
    1994 
    -
    1995 
    --- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages.
    1996 
    -mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
    1997 
    -mkUnusableModuleNameProvidersMap unusables =
    1998 
    -    nonDetFoldUniqMap extend_modmap emptyUniqMap unusables
    1999 
    - where
    2000 
    -    extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings
    2001 
    -      where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
    2002 
    -            bindings = exposed ++ hidden
    2003 
    -
    2004 
    -            origin_reexport =  ModUnusable (UnusableUnit unit reason True)
    2005 
    -            origin_normal   =  ModUnusable (UnusableUnit unit reason False)
    2006 
    -            unit = mkUnit unit_info
    2007 
    -
    2008 
    -            exposed = map get_exposed exposed_mods
    2009 
    -            hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods]
    2010 
    -
    2011 
    -            -- with re-exports, c:Foo can be reexported from two (or more)
    2012 
    -            -- unusable packages:
    2013 
    -            --  Foo -> a:Foo (unusable reason A) -> c:Foo
    2014 
    -            --      -> b:Foo (unusable reason B) -> c:Foo
    2015 
    -            --
    2016 
    -            -- We must be careful to not record the following (#21097):
    2017 
    -            --  Foo -> c:Foo (unusable reason A)
    2018 
    -            --      -> c:Foo (unusable reason B)
    2019 
    -            -- But:
    2020 
    -            --  Foo -> a:Foo (unusable reason A)
    2021 
    -            --      -> b:Foo (unusable reason B)
    2022 
    -            --
    2023 
    -            get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport)
    2024 
    -            get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal)
    2025 
    -              -- in the reexport case, we create a virtual module that doesn't
    2026 
    -              -- exist but we don't care as it's only used as a key in the map.
    2027 
    -
    2028 
    -            exposed_mods = unitExposedModules unit_info
    2029 
    -            hidden_mods  = unitHiddenModules  unit_info
    2030 
    -
    2031 
    --- | Add a list of key/value pairs to a nested map.
    2032 
    ---
    2033 
    --- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
    2034 
    --- when reloading modules in GHCi (see #4029). This ensures that each
    2035 
    --- value is forced before installing into the map.
    2036 
    -addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2)
    2037 
    -          => UniqMap k1 (UniqMap k2 a)
    2038 
    -          -> [(k1, UniqMap k2 a)]
    2039 
    -          -> UniqMap k1 (UniqMap k2 a)
    2040 
    -addListTo = foldl' merge
    2041 
    -  where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v
    2042 
    -
    2043 
    --- | Create a singleton module mapping
    2044 
    -mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
    2045 
    -mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
    2046 
    -
    2047 
    -
    2048 945 
     -- -----------------------------------------------------------------------------
    2049 946 
     -- Package Utils
    2050 947
    ... ... @@ -2185,7 +1082,7 @@ lookupModuleWithSuggestions' pkgs mod_map name mb_pn
    2185 1082 
         suggestions = fuzzyLookup (moduleNameString name) all_mods
    2186 1083
    2187 1084 
         all_mods :: [(String, ModuleSuggestion)]     -- All modules
    2188 
    -    all_mods = sortBy (comparing fst) $
    1085 
    +    all_mods = sortOn fst $
    2189 1086 
             [ (moduleNameString m, suggestion)
    2190 1087 
             | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
    2191 1088 
             , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
    ... ... @@ -2199,78 +1096,7 @@ listVisibleModuleNames state =
    2199 1096 
         map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
    2200 1097 
       where visible (_, ms) = anyUniqMap originVisible ms
    2201 1098
    2202 
    --- | Takes a list of UnitIds (and their "parent" dependency, used for error
    2203 
    --- messages), and returns the list with dependencies included, in reverse
    2204 
    --- dependency order (a units appears before those it depends on).
    2205 
    -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
    2206 
    -closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps
    2207 
    -
    2208 
    --- | Similar to closeUnitDeps but takes a list of already loaded units as an
    2209 
    --- additional argument.
    2210 
    -closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
    2211 
    -closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps
    2212 1099
    2213 
    --- | Add a UnitId and those it depends on (recursively) to the given list of
    2214 
    --- UnitIds if they are not already in it. Return a list in reverse dependency
    2215 
    --- order (a unit appears before those it depends on).
    2216 
    ---
    2217 
    --- The UnitId is looked up in the given UnitInfoMap (to find its dependencies).
    2218 
    --- It it's not found, the optional parent unit is used to return a more precise
    2219 
    --- error message ("dependency of <PARENT>").
    2220 
    -add_unit :: UnitInfoMap
    2221 
    -            -> [UnitId]
    2222 
    -            -> UnitId
    2223 
    -            -> Maybe UnitId
    2224 
    -            -> MaybeErr UnitErr [UnitId]
    2225 
    -add_unit pkg_map ps p mb_parent
    2226 
    -  | p `elem` ps = return ps     -- Check if we've already added this unit
    2227 
    -  | otherwise   = case lookupUnitId' pkg_map p of
    2228 
    -      Nothing   -> Failed (CloseUnitErr p mb_parent)
    2229 
    -      Just info -> do
    2230 
    -         -- Add the unit's dependents also
    2231 
    -         ps' <- foldM add_unit_key ps (unitDepends info)
    2232 
    -         return (p : ps')
    2233 
    -        where
    2234 
    -          add_unit_key xs key
    2235 
    -            = add_unit pkg_map xs key (Just p)
    2236 
    -
    2237 
    -data UnitErr
    2238 
    -  = CloseUnitErr !UnitId !(Maybe UnitId)
    2239 
    -  | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
    2240 
    -  | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]
    2241 
    -
    2242 
    -mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
    2243 
    -mayThrowUnitErr = \case
    2244 
    -    Failed e    -> throwGhcExceptionIO
    2245 
    -                    $ CmdLineError
    2246 
    -                    $ renderWithContext defaultSDocContext
    2247 
    -                    $ withPprStyle defaultUserStyle
    2248 
    -                    $ ppr e
    2249 
    -    Succeeded a -> return a
    2250 
    -
    2251 
    -instance Outputable UnitErr where
    2252 
    -    ppr = \case
    2253 
    -        CloseUnitErr p mb_parent
    2254 
    -            -> (text "unknown unit:" <+> ppr p)
    2255 
    -               <> case mb_parent of
    2256 
    -                     Nothing     -> Outputable.empty
    2257 
    -                     Just parent -> space <> parens (text "dependency of"
    2258 
    -                                              <+> ftext (unitIdFS parent))
    2259 
    -        PackageFlagErr flag reasons
    2260 
    -            -> flag_err (pprFlag flag) reasons
    2261 
    -
    2262 
    -        TrustFlagErr flag reasons
    2263 
    -            -> flag_err (pprTrustFlag flag) reasons
    2264 
    -      where
    2265 
    -        flag_err flag_doc reasons =
    2266 
    -            text "cannot satisfy "
    2267 
    -            <> flag_doc
    2268 
    -            <> (if null reasons then Outputable.empty else text ": ")
    2269 
    -            $$ nest 4 (vcat (map ppr_reason reasons) $$
    2270 
    -                      text "(use -v for more information)")
    2271 
    -
    2272 
    -        ppr_reason (p, reason) =
    2273 
    -            pprReason (ppr (unitId p) <+> text "is") reason
    2274 1100
    2275 1101 
     -- | Return this list of requirement interfaces that need to be merged
    2276 1102 
     -- to form @mod_name@, or @[]@ if this is not a requirement.
    ... ... @@ -2328,37 +1154,23 @@ pprUnitsSimple ue = pprUnitsWith pprIPI ue
    2328 1154 
                                t = if isUnitInfoTrusted ue ipi then text "T" else text " "
    2329 1155 
                            in e <> t <> text "  " <> ftext i
    2330 1156
    2331 
    --- | Show the mapping of modules to where they come from.
    2332 
    -pprModuleMap :: ModuleNameProvidersMap -> SDoc
    2333 
    -pprModuleMap mod_map =
    2334 
    -  vcat (map pprLine (nonDetUniqMapToList mod_map))
    2335 
    -    where
    2336 
    -      pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e)))
    2337 
    -      pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
    2338 
    -      pprEntry m (m',o)
    2339 
    -        | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o)
    2340 
    -        | otherwise = ppr m' <+> parens (ppr o)
    1157 
    +-- | Print unit-ids with UnitInfo found in the given UnitState
    1158 
    +pprWithUnitState :: UnitState -> SDoc -> SDoc
    1159 
    +pprWithUnitState state = updSDocContext (\ctx -> ctx
    1160 
    +   { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)
    1161 
    +   })
    1162 
    +
    1163 
    +-- | Print raw unit-ids, without removing the hash
    1164 
    +pprRawUnitIds :: SDoc -> SDoc
    1165 
    +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext })
    2341 1166
    2342 1167 
     fsPackageName :: UnitInfo -> FastString
    2343 1168 
     fsPackageName info = fs
    2344 1169 
        where
    2345 1170 
           PackageName fs = unitPackageName info
    2346 1171
    2347 
    --- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged.
    2348 
    -instUnitToUnit :: InstantiatedUnit -> Unit
    2349 
    -instUnitToUnit iuid =
    2350 
    -    -- NB: suppose that we want to compare the instantiated
    2351 
    -    -- unit p[H=impl:H] against p+abcd (where p+abcd
    2352 
    -    -- happens to be the existing, installed version of
    2353 
    -    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]
    2354 
    -    -- VirtUnit, they won't compare equal; only
    2355 
    -    -- after improvement will the equality hold.
    2356 
    -    VirtUnit iuid
    2357 
    -
    2358 
    -
    2359 
    --- | Substitution on module variables, mapping module names to module
    2360 
    --- identifiers.
    2361 
    -type ShHoleSubst = ModuleNameEnv Module
    1172 
    +-- -----------------------------------------------------------------------------
    1173 
    +-- Module renaming
    2362 1174
    2363 1175 
     -- | Substitutes holes in a 'Module'.  NOT suitable for being called
    2364 1176 
     -- directly on a 'nameModule', see Note [Representation of module/name variables].
    ... ... @@ -2374,44 +1186,19 @@ renameHoleModule state = renameHoleModule' (unitInfoMap state)
    2374 1186 
     renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit
    2375 1187 
     renameHoleUnit state = renameHoleUnit' (unitInfoMap state)
    2376 1188
    2377 
    --- | Like 'renameHoleModule', but requires only 'UnitInfoMap'
    2378 
    --- so it can be used by "GHC.Unit.State".
    2379 
    -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module
    2380 
    -renameHoleModule' pkg_map env m
    2381 
    -  | not (isHoleModule m) =
    2382 
    -        let uid = renameHoleUnit' pkg_map env (moduleUnit m)
    2383 
    -        in mkModule uid (moduleName m)
    2384 
    -  | Just m' <- lookupUFM env (moduleName m) = m'
    2385 
    -  -- NB m = <Blah>, that's what's in scope.
    2386 
    -  | otherwise = m
    2387 
    -
    2388 
    --- | Like 'renameHoleUnit', but requires only 'UnitInfoMap'
    2389 
    --- so it can be used by "GHC.Unit.State".
    2390 
    -renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit
    2391 
    -renameHoleUnit' pkg_map env uid =
    2392 
    -    case uid of
    2393 
    -      (VirtUnit
    2394 
    -        InstantiatedUnit{ instUnitInstanceOf = cid
    2395 
    -                        , instUnitInsts      = insts
    2396 
    -                        , instUnitHoles      = fh })
    2397 
    -          -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env)
    2398 
    -                then uid
    2399 
    -                else mkVirtUnit cid
    2400 
    -                          (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts)
    2401 
    -      _ -> uid
    2402 
    -
    2403 1189 
     -- | Injects an 'InstantiatedModule' to 'Module' (see also
    2404 1190 
     -- 'instUnitToUnit'.
    2405 1191 
     instModuleToModule :: InstantiatedModule -> Module
    2406 1192 
     instModuleToModule (Module iuid mod_name) =
    2407 1193 
         mkModule (instUnitToUnit iuid) mod_name
    2408 1194
    2409 
    --- | Print unit-ids with UnitInfo found in the given UnitState
    2410 
    -pprWithUnitState :: UnitState -> SDoc -> SDoc
    2411 
    -pprWithUnitState state = updSDocContext (\ctx -> ctx
    2412 
    -   { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)
    2413 
    -   })
    2414 
    -
    2415 
    --- | Print raw unit-ids, without removing the hash
    2416 
    -pprRawUnitIds :: SDoc -> SDoc
    2417 
    -pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext })
    1195 
    +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged.
    1196 
    +instUnitToUnit :: InstantiatedUnit -> Unit
    1197 
    +instUnitToUnit iuid =
    1198 
    +    -- NB: suppose that we want to compare the instantiated
    1199 
    +    -- unit p[H=impl:H] against p+abcd (where p+abcd
    1200 
    +    -- happens to be the existing, installed version of
    1201 
    +    -- p[H=impl:H].  If we *only* wrap in p[H=impl:H]
    1202 
    +    -- VirtUnit, they won't compare equal; only
    1203 
    +    -- after improvement will the equality hold.
    1204 
    +    VirtUnit iuid

  • compiler/GHC/Unit/State.hs-boot
    1 1 
     module GHC.Unit.State where
    2 2
    3 3 
     data UnitState
    4 
    -data ModuleSuggestion
    5 
    -data ModuleOrigin
    6 
    -data UnusableUnit

  • compiler/GHC/Unit/Types.hs
    ... ... @@ -578,7 +578,7 @@ had used @-ignore-package@).
    578 578 
     The affected packages are compiled with, e.g., @-this-unit-id base@, so that
    579 579 
     the symbols in the object files have the unversioned unit id in their name.
    580 580
    581 
    -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here.
    581 
    +Make sure you change 'wiredInUnitIds' if you add an entry here.
    582 582
    583 583 
     -}
    584 584

  • compiler/ghc.cabal.in
    ... ... @@ -968,6 +968,14 @@ Library
    968 968 
             GHC.Unit.Env
    969 969 
             GHC.Unit.External
    970 970 
             GHC.Unit.External.Database
    971 
    +        GHC.Unit.External.Index
    972 
    +        GHC.Unit.External.Substitution
    973 
    +        GHC.Unit.External.Query
    974 
    +        GHC.Unit.External.ModuleOrigin
    975 
    +        GHC.Unit.External.Providers
    976 
    +        GHC.Unit.External.Validate
    977 
    +        GHC.Unit.External.Visibility
    978 
    +        GHC.Unit.External.Wired
    971 979 
             GHC.Unit.Finder
    972 980 
             GHC.Unit.Finder.Types
    973 981 
             GHC.Unit.Home

  • testsuite/tests/driver/T26423/Hello.hs
    1 
    +module Hello where
    2 
    +
    3 
    +import Tes
    4 
    +
    5 
    +hello :: String
    6 
    +hello = "Imported from dependency 'test':" <> show test

  • testsuite/tests/driver/T26423/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk
    4 
    +
    5 
    +LOCAL_PKGCONF=test.package.conf.d
    6 
    +
    7 
    +clean:
    8 
    +	rm -f test/*.o test/*.hi *.o *.hi
    9 
    +	rm -rf $(LOCAL_PKGCONF)
    10 
    +
    11 
    +.PHONY: T26423
    12 
    +T26423:
    13 
    +	@rm -rf $(LOCAL_PKGCONF)
    14 
    +	"$(TEST_HC)" $(TEST_HC_OPTS) -this-unit-id test-1.0 -c test/Test.hs
    15 
    +	"$(GHC_PKG)" init $(LOCAL_PKGCONF)
    16 
    +	"$(GHC_PKG)" --no-user-package-db -f $(LOCAL_PKGCONF) register test/test.pkg -v0
    17 
    +	"$(TEST_HC)" $(TEST_HC_OPTS) -package-db $(LOCAL_PKGCONF)/  -package ghc  T26423.hs
    18 
    +	./T26423 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"

  • testsuite/tests/driver/T26423/T26423.hs
    1 
    +import GHC
    2 
    +import GHC.Data.OsPath
    3 
    +import GHC.Driver.Env
    4 
    +import GHC.Driver.Monad
    5 
    +import GHC.Unit.Env
    6 
    +import GHC.Plugins
    7 
    +import GHC.Prelude
    8 
    +
    9 
    +import Control.Exception
    10 
    +import Control.Monad
    11 
    +import Control.Monad.IO.Class
    12 
    +import System.Environment
    13 
    +
    14 
    +-- No sign of new db in output:
    15 
    +-- "Just [DB: <libdir>/package.conf.d]"
    16 
    +bad :: IO ()
    17 
    +bad = do
    18 
    +  libdir:_ <- getArgs
    19 
    +  runGhcT (Just libdir) $ do
    20 
    +    df <- getSessionDynFlags
    21 
    +    -- The first call simulates having modified the DynFlags once before
    22 
    +    setSessionDynFlags df
    23 
    +    setSessionDynFlags $
    24 
    +      df { packageDBFlags = PackageDB (PkgDbPath $ os "test.package.conf.d") : (packageDBFlags df)
    25 
    +        , packageFlags = [ExposePackage "testpkg" (PackageArg "testpkg") (ModRenaming True [])]
    26 
    +      }
    27 
    +
    28 
    +    hsc_env <- getSession
    29 
    +    t <- guessTarget "Heo.hs" Nothing Nothing
    30 
    +    setTargets [t]
    31 
    +    r <- load LoadAllTargets
    32 
    +    when (failed r) $ do
    33 
    +      liftIO $ throwIO $ ErrorCall "Failed to load the target"
    34 
    +
    35 
    +    execStmt "hello" execOptions
    36 
    +    liftIO $ putStrLn "Successfully compiled Hello.hs"
    37 
    +
    38 
    +main = bad >>= print

  • testsuite/tests/driver/T26423/all.T
    1 
    +test('T26423', [extra_files(['Hello.hs', 'test/'])], makefile_test, [])

  • testsuite/tests/driver/T26423/test/Test.hs
    1 
    +module Test where
    2 
    +
    3 
    +test :: Int
    4 
    +test = 42

  • testsuite/tests/driver/T26423/test/test.pkg
    1 
    +name: test
    2 
    +version: 1.0
    3 
    +id: test-1.0
    4 
    +key: test-1.0
    5 
    +exposed-modules: Test
    6 
    +import-dirs: ${pkgroot}/test
    7 
    +library-dirs: ${pkgroot}/test
    8 
    +exposed: True

    • —
    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/-/compare/cffe0d451d67c72c2b1cfc62e36f7022c46a18fc...cead91298f53b22cc02e108c4bf947b108aa8024 at 1784212057