{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Usage (
mkUsageInfo, mkUsedNames,
UsageConfig(..),
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Tc.Types
import GHC.Iface.Load
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Fingerprint
import GHC.Utils.Panic
import GHC.Utils.Monad
import GHC.Types.Name
import GHC.Types.Name.Set ( NameSet, allUses )
import GHC.Types.Unique.Set
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module.Imported
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import Data.IORef
import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC.Linker.Types
import GHC.Unit.Finder
import GHC.Types.Unique.DFM
import GHC.Driver.Plugins
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus :: TcGblEnv -> DefUses
tcg_dus = DefUses
dus } = DefUses -> NameSet
allUses DefUses
dus
data UsageConfig = UsageConfig
{ UsageConfig -> Bool
uc_safe_implicit_imps_req :: !Bool
}
mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
-> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IfG [Usage]
mkUsageInfo :: UsageConfig
-> Plugins
-> FinderCache
-> UnitEnv
-> Module
-> ImportedMods
-> NameSet
-> [FilePath]
-> [(Module, Fingerprint)]
-> [Linkable]
-> PkgsLoaded
-> IfG [Usage]
mkUsageInfo UsageConfig
uc Plugins
plugins FinderCache
fc UnitEnv
unit_env Module
this_mod ImportedMods
dir_imp_mods NameSet
used_names [FilePath]
dependent_files [(Module, Fingerprint)]
merged [Linkable]
needed_links PkgsLoaded
needed_pkgs
= do
ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (ExternalUnitCache -> IORef ExternalPackageState
euc_eps (UnitEnv -> ExternalUnitCache
ue_eps UnitEnv
unit_env))
[Fingerprint]
hashes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Fingerprint
getFileHash [FilePath]
dependent_files
let hu :: HomeUnit
hu = UnitEnv -> HomeUnit
unsafeGetHomeUnit UnitEnv
unit_env
hug :: HomeUnitGraph
hug = UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env
[Usage]
object_usages <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PackageIfaceTable
-> Plugins
-> FinderCache
-> HomeUnitGraph
-> [Linkable]
-> PkgsLoaded
-> IO [Usage]
mkObjectUsage (ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps) Plugins
plugins FinderCache
fc HomeUnitGraph
hug [Linkable]
needed_links PkgsLoaded
needed_pkgs
let all_home_ids :: Set UnitId
all_home_ids = UnitEnv -> Set UnitId
ue_all_home_unit_ids UnitEnv
unit_env
[Usage]
mod_usages <- UsageConfig
-> HomeUnit
-> Set UnitId
-> Module
-> ImportedMods
-> NameSet
-> IfG [Usage]
mk_mod_usage_info UsageConfig
uc HomeUnit
hu Set UnitId
all_home_ids Module
this_mod
ImportedMods
dir_imp_mods NameSet
used_names
let usages :: [Usage]
usages = [Usage]
mod_usages forall a. [a] -> [a] -> [a]
++ [ UsageFile { usg_file_path :: FilePath
usg_file_path = FilePath
f
, usg_file_hash :: Fingerprint
usg_file_hash = Fingerprint
hash
, usg_file_label :: Maybe FilePath
usg_file_label = forall a. Maybe a
Nothing }
| (FilePath
f, Fingerprint
hash) <- forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
dependent_files [Fingerprint]
hashes ]
forall a. [a] -> [a] -> [a]
++ [ UsageMergedRequirement
{ usg_mod :: Module
usg_mod = Module
mod,
usg_mod_hash :: Fingerprint
usg_mod_hash = Fingerprint
hash
}
| (Module
mod, Fingerprint
hash) <- [(Module, Fingerprint)]
merged ]
forall a. [a] -> [a] -> [a]
++ [Usage]
object_usages
[Usage]
usages forall a b. [a] -> b -> b
`seqList` forall (m :: * -> *) a. Monad m => a -> m a
return [Usage]
usages
mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage]
mkObjectUsage :: PackageIfaceTable
-> Plugins
-> FinderCache
-> HomeUnitGraph
-> [Linkable]
-> PkgsLoaded
-> IO [Usage]
mkObjectUsage PackageIfaceTable
pit Plugins
plugins FinderCache
fc HomeUnitGraph
hug [Linkable]
th_links_needed PkgsLoaded
th_pkgs_needed = do
let ls :: [Linkable]
ls = forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubOn Linkable -> Module
linkableModule ([Linkable]
th_links_needed forall a. [a] -> [a] -> [a]
++ [Linkable]
plugins_links_needed)
ds :: [LibrarySpec]
ds = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LoadedPkgInfo -> [LibrarySpec]
loaded_pkg_hs_objs forall a b. (a -> b) -> a -> b
$ forall key elt. UniqDFM key elt -> [elt]
eltsUDFM (forall key elt.
UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM PkgsLoaded
th_pkgs_needed PkgsLoaded
plugin_pkgs_needed)
([Linkable]
plugins_links_needed, PkgsLoaded
plugin_pkgs_needed) = Plugins -> ([Linkable], PkgsLoaded)
loadedPluginDeps Plugins
plugins
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a b. (a -> b) -> [a] -> [b]
map Linkable -> IO [Usage]
linkableToUsage [Linkable]
ls forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map LibrarySpec -> IO [Usage]
librarySpecToUsage [LibrarySpec]
ds)
where
linkableToUsage :: Linkable -> IO [Usage]
linkableToUsage (LM UTCTime
_ Module
m [Unlinked]
uls) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module -> Unlinked -> IO Usage
unlinkedToUsage Module
m) [Unlinked]
uls
msg :: GenModule unit -> FilePath
msg GenModule unit
m = ModuleName -> FilePath
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName GenModule unit
m) forall a. [a] -> [a] -> [a]
++ FilePath
"[TH] changed"
fing :: Maybe FilePath -> FilePath -> IO Usage
fing Maybe FilePath
mmsg FilePath
fn = FilePath -> Fingerprint -> Maybe FilePath -> Usage
UsageFile FilePath
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FinderCache -> FilePath -> IO Fingerprint
lookupFileCache FinderCache
fc FilePath
fn forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
mmsg
unlinkedToUsage :: Module -> Unlinked -> IO Usage
unlinkedToUsage Module
m Unlinked
ul =
case Unlinked -> Maybe FilePath
nameOfObject_maybe Unlinked
ul of
Just FilePath
fn -> Maybe FilePath -> FilePath -> IO Usage
fing (forall a. a -> Maybe a
Just (forall {unit}. GenModule unit -> FilePath
msg Module
m)) FilePath
fn
Maybe FilePath
Nothing -> do
let miface :: Maybe ModIface
miface = HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pit Module
m
case Maybe ModIface
miface of
Maybe ModIface
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"mkObjectUsage" (forall a. Outputable a => a -> SDoc
ppr Module
m)
Just ModIface
iface ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModuleName -> UnitId -> Fingerprint -> Usage
UsageHomeModuleInterface (forall unit. GenModule unit -> ModuleName
moduleName Module
m) (Unit -> UnitId
toUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
m) (ModIfaceBackend -> Fingerprint
mi_iface_hash (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
librarySpecToUsage :: LibrarySpec -> IO [Usage]
librarySpecToUsage :: LibrarySpec -> IO [Usage]
librarySpecToUsage (Objects [FilePath]
os) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe FilePath -> FilePath -> IO Usage
fing forall a. Maybe a
Nothing) [FilePath]
os
librarySpecToUsage (Archive FilePath
fn) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe FilePath -> FilePath -> IO Usage
fing forall a. Maybe a
Nothing) [FilePath
fn]
librarySpecToUsage (DLLPath FilePath
fn) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Maybe FilePath -> FilePath -> IO Usage
fing forall a. Maybe a
Nothing) [FilePath
fn]
librarySpecToUsage LibrarySpec
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
mk_mod_usage_info :: UsageConfig
-> HomeUnit
-> Set.Set UnitId
-> Module
-> ImportedMods
-> NameSet
-> IfG [Usage]
mk_mod_usage_info :: UsageConfig
-> HomeUnit
-> Set UnitId
-> Module
-> ImportedMods
-> NameSet
-> IfG [Usage]
mk_mod_usage_info UsageConfig
uc HomeUnit
home_unit Set UnitId
home_unit_ids Module
this_mod ImportedMods
direct_imports NameSet
used_names
= forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Module -> IfG (Maybe Usage)
mkUsageM [Module]
usage_mods
where
safe_implicit_imps_req :: Bool
safe_implicit_imps_req = UsageConfig -> Bool
uc_safe_implicit_imps_req UsageConfig
uc
used_mods :: [Module]
used_mods = forall a. ModuleEnv a -> [Module]
moduleEnvKeys ModuleEnv [OccName]
ent_map
dir_imp_mods :: [Module]
dir_imp_mods = forall a. ModuleEnv a -> [Module]
moduleEnvKeys ImportedMods
direct_imports
all_mods :: [Module]
all_mods = [Module]
used_mods forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Module]
used_mods) [Module]
dir_imp_mods
usage_mods :: [Module]
usage_mods = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Module -> Module -> Ordering
stableModuleCmp [Module]
all_mods
ent_map :: ModuleEnv [OccName]
ent_map :: ModuleEnv [OccName]
ent_map = forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet Name -> ModuleEnv [OccName] -> ModuleEnv [OccName]
add_mv forall a. ModuleEnv a
emptyModuleEnv NameSet
used_names
where
add_mv :: Name -> ModuleEnv [OccName] -> ModuleEnv [OccName]
add_mv Name
name ModuleEnv [OccName]
mv_map
| Name -> Bool
isWiredInName Name
name = ModuleEnv [OccName]
mv_map
| Bool
otherwise
= case Name -> Maybe Module
nameModule_maybe Name
name of
Maybe Module
Nothing -> forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isSystemName Name
name) (forall a. Outputable a => a -> SDoc
ppr Name
name) ModuleEnv [OccName]
mv_map
Just Module
mod ->
let mod' :: Module
mod' = if forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod
then HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
else Module
mod
in forall a.
(a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnvWith (\[OccName]
_ [OccName]
xs -> OccName
occforall a. a -> [a] -> [a]
:[OccName]
xs) ModuleEnv [OccName]
mv_map Module
mod' [OccName
occ]
where occ :: OccName
occ = Name -> OccName
nameOccName Name
name
mkUsageM :: Module -> IfG (Maybe Usage)
mkUsageM :: Module -> IfG (Maybe Usage)
mkUsageM Module
mod | Module
mod forall a. Eq a => a -> a -> Bool
== Module
this_mod
Bool -> Bool -> Bool
|| forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
interactiveUnit
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
mkUsageM Module
mod = do
ModIface
iface <- forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface (forall doc. IsLine doc => FilePath -> doc
text FilePath
"mk_mod_usage") Module
mod
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Module -> ModIface -> Maybe Usage
mkUsage Module
mod ModIface
iface
mkUsage :: Module -> ModIface -> Maybe Usage
mkUsage :: Module -> ModIface -> Maybe Usage
mkUsage Module
mod ModIface
iface
| Unit -> UnitId
toUnitId (forall unit. GenModule unit -> unit
moduleUnit Module
mod) forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
home_unit_ids
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ UsagePackageModule{ usg_mod :: Module
usg_mod = Module
mod,
usg_mod_hash :: Fingerprint
usg_mod_hash = Fingerprint
mod_hash,
usg_safe :: Bool
usg_safe = Bool
imp_safe }
| (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OccName]
used_occs
Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Fingerprint
export_hash
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
is_direct_import
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
finsts_mod)
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just UsageHomeModule {
usg_mod_name :: ModuleName
usg_mod_name = forall unit. GenModule unit -> ModuleName
moduleName Module
mod,
usg_unit_id :: UnitId
usg_unit_id = Unit -> UnitId
toUnitId (forall unit. GenModule unit -> unit
moduleUnit Module
mod),
usg_mod_hash :: Fingerprint
usg_mod_hash = Fingerprint
mod_hash,
usg_exports :: Maybe Fingerprint
usg_exports = Maybe Fingerprint
export_hash,
usg_entities :: [(OccName, Fingerprint)]
usg_entities = forall k a. Map k a -> [(k, a)]
Map.toList Map OccName Fingerprint
ent_hashs,
usg_safe :: Bool
usg_safe = Bool
imp_safe }
where
finsts_mod :: Bool
finsts_mod = ModIfaceBackend -> Bool
mi_finsts (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
hash_env :: OccName -> Maybe (OccName, Fingerprint)
hash_env = ModIfaceBackend -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
mod_hash :: Fingerprint
mod_hash = ModIfaceBackend -> Fingerprint
mi_mod_hash (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
export_hash :: Maybe Fingerprint
export_hash | Bool
depend_on_exports = forall a. a -> Maybe a
Just (ModIfaceBackend -> Fingerprint
mi_exp_hash (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
| Bool
otherwise = forall a. Maybe a
Nothing
by_is_safe :: ImportedBy -> Bool
by_is_safe (ImportedByUser ImportedModsVal
imv) = ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
imv
by_is_safe ImportedBy
_ = Bool
False
(Bool
is_direct_import, Bool
imp_safe)
= case forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ImportedMods
direct_imports Module
mod of
Just [ImportedBy]
bys -> (Bool
True, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ImportedBy -> Bool
by_is_safe [ImportedBy]
bys)
Maybe [ImportedBy]
Nothing -> (Bool
False, Bool
safe_implicit_imps_req)
used_occs :: [OccName]
used_occs = forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv [OccName]
ent_map Module
mod forall a. Maybe a -> a -> a
`orElse` []
ent_hashs :: Map OccName Fingerprint
ent_hashs :: Map OccName Fingerprint
ent_hashs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map OccName -> (OccName, Fingerprint)
lookup_occ [OccName]
used_occs)
lookup_occ :: OccName -> (OccName, Fingerprint)
lookup_occ OccName
occ =
case OccName -> Maybe (OccName, Fingerprint)
hash_env OccName
occ of
Maybe (OccName, Fingerprint)
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"mkUsage" (forall a. Outputable a => a -> SDoc
ppr Module
mod forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr OccName
occ forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr NameSet
used_names)
Just (OccName, Fingerprint)
r -> (OccName, Fingerprint)
r
depend_on_exports :: Bool
depend_on_exports = Bool
is_direct_import