{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Usage (
mkUsageInfo, mkUsedNames,
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Tc.Types
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Fingerprint
import GHC.Utils.Panic
import GHC.Types.Name
import GHC.Types.Name.Set ( NameSet, allUses )
import GHC.Types.Unique.Set
import GHC.Unit
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.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
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
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
-> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage]
mkUsageInfo :: HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [FilePath]
-> [(Module, Fingerprint)]
-> [Linkable]
-> PkgsLoaded
-> IO [Usage]
mkUsageInfo HscEnv
hsc_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 <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
[Fingerprint]
hashes <- 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
[Usage]
object_usages <- PackageIfaceTable
-> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]
mkObjectUsage (ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps) HscEnv
hsc_env [Linkable]
needed_links PkgsLoaded
needed_pkgs
let mod_usages :: [Usage]
mod_usages = PackageIfaceTable
-> HscEnv -> Module -> ImportedMods -> NameSet -> [Usage]
mk_mod_usage_info (ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps) HscEnv
hsc_env Module
this_mod
ImportedMods
dir_imp_mods NameSet
used_names
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 -> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]
mkObjectUsage :: PackageIfaceTable
-> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]
mkObjectUsage PackageIfaceTable
pit HscEnv
hsc_env [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 forall a b. (a -> b) -> a -> b
$ HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env
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 (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) 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 (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) 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 -> Fingerprint -> Usage
UsageHomeModuleInterface (forall unit. GenModule unit -> ModuleName
moduleName 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 :: PackageIfaceTable
-> HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [Usage]
mk_mod_usage_info :: PackageIfaceTable
-> HscEnv -> Module -> ImportedMods -> NameSet -> [Usage]
mk_mod_usage_info PackageIfaceTable
pit HscEnv
hsc_env Module
this_mod ImportedMods
direct_imports NameSet
used_names
= forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Module -> Maybe Usage
mkUsage [Module]
usage_mods
where
hpt :: HomeUnitGraph
hpt = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
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
mkUsage :: Module -> Maybe Usage
mkUsage :: Module -> Maybe Usage
mkUsage Module
mod
| forall a. Maybe a -> Bool
isNothing Maybe ModIface
maybe_iface
Bool -> Bool -> Bool
|| Module
mod forall a. Eq a => a -> a -> Bool
== Module
this_mod
= forall a. Maybe a
Nothing
| Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod)
= forall a. a -> Maybe a
Just 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_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
maybe_iface :: Maybe ModIface
maybe_iface = HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hpt PackageIfaceTable
pit Module
mod
Just ModIface
iface = Maybe ModIface
maybe_iface
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, DynFlags -> Bool
safeImplicitImpsReq DynFlags
dflags)
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 SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr OccName
occ SDoc -> SDoc -> SDoc
<+> 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