{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Iface.Recomp
( checkOldIface
, RecompileRequired(..)
, needsRecompileBecause
, recompThen
, MaybeValidated(..)
, outOfDateItemBecause
, RecompReason (..)
, CompileReason(..)
, recompileRequired
, addFingerprints
)
where
import GHC.Prelude
import GHC.Data.FastString
import GHC.Driver.Backend
import GHC.Driver.Config.Finder
import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Driver.Plugins
import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
import GHC.Iface.Load
import GHC.Iface.Recomp.Flags
import GHC.Iface.Env
import GHC.Core
import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
import GHC.Utils.Logger
import GHC.Utils.Constants (debugIsOn)
import GHC.Types.Annotations
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
import GHC.Types.Unique.Map
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.Deps
import Control.Monad
import Data.List (sortBy, sort, sortOn)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import Data.Either
import qualified Data.Semigroup
import GHC.List (uncons)
import Data.Ord
import Data.Containers.ListUtils
import Data.Bifunctor
import GHC.Iface.Errors.Ppr
data RecompileRequired
= UpToDate
| NeedsRecompile !CompileReason
deriving (RecompileRequired -> RecompileRequired -> AnyHpcUsage
(RecompileRequired -> RecompileRequired -> AnyHpcUsage)
-> (RecompileRequired -> RecompileRequired -> AnyHpcUsage)
-> Eq RecompileRequired
forall a.
(a -> a -> AnyHpcUsage) -> (a -> a -> AnyHpcUsage) -> Eq a
$c== :: RecompileRequired -> RecompileRequired -> AnyHpcUsage
== :: RecompileRequired -> RecompileRequired -> AnyHpcUsage
$c/= :: RecompileRequired -> RecompileRequired -> AnyHpcUsage
/= :: RecompileRequired -> RecompileRequired -> AnyHpcUsage
Eq)
needsRecompileBecause :: RecompReason -> RecompileRequired
needsRecompileBecause :: RecompReason -> RecompileRequired
needsRecompileBecause = CompileReason -> RecompileRequired
NeedsRecompile (CompileReason -> RecompileRequired)
-> (RecompReason -> CompileReason)
-> RecompReason
-> RecompileRequired
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecompReason -> CompileReason
RecompBecause
data MaybeValidated a
= UpToDateItem a
| OutOfDateItem
!CompileReason
(Maybe a)
deriving ((forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b)
-> (forall a b. a -> MaybeValidated b -> MaybeValidated a)
-> Functor MaybeValidated
forall a b. a -> MaybeValidated b -> MaybeValidated a
forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b
fmap :: forall a b. (a -> b) -> MaybeValidated a -> MaybeValidated b
$c<$ :: forall a b. a -> MaybeValidated b -> MaybeValidated a
<$ :: forall a b. a -> MaybeValidated b -> MaybeValidated a
Functor)
instance Outputable a => Outputable (MaybeValidated a) where
ppr :: MaybeValidated a -> SDoc
ppr (UpToDateItem a
a) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UpToDate" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a
ppr (OutOfDateItem CompileReason
r Maybe a
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OutOfDate: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CompileReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompileReason
r
outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause :: forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
reason Maybe a
item = CompileReason -> Maybe a -> MaybeValidated a
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem (RecompReason -> CompileReason
RecompBecause RecompReason
reason) Maybe a
item
data CompileReason
= MustCompile
| RecompBecause !RecompReason
deriving (CompileReason -> CompileReason -> AnyHpcUsage
(CompileReason -> CompileReason -> AnyHpcUsage)
-> (CompileReason -> CompileReason -> AnyHpcUsage)
-> Eq CompileReason
forall a.
(a -> a -> AnyHpcUsage) -> (a -> a -> AnyHpcUsage) -> Eq a
$c== :: CompileReason -> CompileReason -> AnyHpcUsage
== :: CompileReason -> CompileReason -> AnyHpcUsage
$c/= :: CompileReason -> CompileReason -> AnyHpcUsage
/= :: CompileReason -> CompileReason -> AnyHpcUsage
Eq)
instance Outputable RecompileRequired where
ppr :: RecompileRequired -> SDoc
ppr RecompileRequired
UpToDate = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UpToDate"
ppr (NeedsRecompile CompileReason
reason) = CompileReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompileReason
reason
instance Outputable CompileReason where
ppr :: CompileReason -> SDoc
ppr CompileReason
MustCompile = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MustCompile"
ppr (RecompBecause RecompReason
r) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RecompBecause" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> RecompReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompReason
r
instance Semigroup RecompileRequired where
RecompileRequired
UpToDate <> :: RecompileRequired -> RecompileRequired -> RecompileRequired
<> RecompileRequired
r = RecompileRequired
r
RecompileRequired
mc <> RecompileRequired
_ = RecompileRequired
mc
instance Monoid RecompileRequired where
mempty :: RecompileRequired
mempty = RecompileRequired
UpToDate
data RecompReason
= UnitDepRemoved UnitId
| ModulePackageChanged FastString
| SourceFileChanged
| ThisUnitIdChanged
| ImpurePlugin
| PluginsChanged
| PluginFingerprintChanged
| ModuleInstChanged
| HieMissing
| HieOutdated
| SigsMergeChanged
| ModuleChanged ModuleName
| ModuleRemoved (UnitId, ModuleName)
| ModuleAdded (UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
| CustomReason String
| FlagsChanged
| OptimFlagsChanged
| HpcFlagsChanged
| MissingBytecode
| MissingObjectFile
| MissingDynObjectFile
| MissingDynHiFile
| MismatchedDynHiFile
| ObjectsChanged
| LibraryChanged
| THWithJS
deriving (RecompReason -> RecompReason -> AnyHpcUsage
(RecompReason -> RecompReason -> AnyHpcUsage)
-> (RecompReason -> RecompReason -> AnyHpcUsage) -> Eq RecompReason
forall a.
(a -> a -> AnyHpcUsage) -> (a -> a -> AnyHpcUsage) -> Eq a
$c== :: RecompReason -> RecompReason -> AnyHpcUsage
== :: RecompReason -> RecompReason -> AnyHpcUsage
$c/= :: RecompReason -> RecompReason -> AnyHpcUsage
/= :: RecompReason -> RecompReason -> AnyHpcUsage
Eq)
instance Outputable RecompReason where
ppr :: RecompReason -> SDoc
ppr = \case
UnitDepRemoved UnitId
uid -> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"removed"
ModulePackageChanged FastString
s -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package changed"
RecompReason
SourceFileChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Source file changed"
RecompReason
ThisUnitIdChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-this-unit-id changed"
RecompReason
ImpurePlugin -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Impure plugin forced recompilation"
RecompReason
PluginsChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Plugins changed"
RecompReason
PluginFingerprintChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Plugin fingerprint changed"
RecompReason
ModuleInstChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Implementing module changed"
RecompReason
HieMissing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HIE file is missing"
RecompReason
HieOutdated -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HIE file is out of date"
RecompReason
SigsMergeChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Signatures to merge in changed"
ModuleChanged ModuleName
m -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed"
ModuleChangedRaw ModuleName
m -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed (raw)"
ModuleChangedIface ModuleName
m -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed (interface)"
ModuleRemoved (UnitId
_uid, ModuleName
m) -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"removed"
ModuleAdded (UnitId
_uid, ModuleName
m) -> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"added"
FileChanged String
fp -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
fp SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"changed"
CustomReason String
s -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
s
RecompReason
FlagsChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Flags changed"
RecompReason
OptimFlagsChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Optimisation flags changed"
RecompReason
HpcFlagsChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HPC flags changed"
RecompReason
MissingBytecode -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing bytecode"
RecompReason
MissingObjectFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing object file"
RecompReason
MissingDynObjectFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing dynamic object file"
RecompReason
MissingDynHiFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Missing dynamic interface file"
RecompReason
MismatchedDynHiFile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Mismatched dynamic interface file"
RecompReason
ObjectsChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Objects changed"
RecompReason
LibraryChanged -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Library changed"
RecompReason
THWithJS -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"JS backend always recompiles modules using Template Haskell for now (#23013)"
recompileRequired :: RecompileRequired -> Bool
recompileRequired :: RecompileRequired -> AnyHpcUsage
recompileRequired RecompileRequired
UpToDate = AnyHpcUsage
False
recompileRequired RecompileRequired
_ = AnyHpcUsage
True
recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired
recompThen :: forall (m :: * -> *).
Monad m =>
m RecompileRequired -> m RecompileRequired -> m RecompileRequired
recompThen m RecompileRequired
ma m RecompileRequired
mb = m RecompileRequired
ma m RecompileRequired
-> (RecompileRequired -> m RecompileRequired)
-> m RecompileRequired
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
RecompileRequired
UpToDate -> m RecompileRequired
mb
rr :: RecompileRequired
rr@(NeedsRecompile CompileReason
_) -> RecompileRequired -> m RecompileRequired
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecompileRequired
rr
checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired
checkList :: forall (m :: * -> *).
Monad m =>
[m RecompileRequired] -> m RecompileRequired
checkList = \case
[] -> RecompileRequired -> m RecompileRequired
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
(m RecompileRequired
check : [m RecompileRequired]
checks) -> m RecompileRequired
check m RecompileRequired -> m RecompileRequired -> m RecompileRequired
forall (m :: * -> *).
Monad m =>
m RecompileRequired -> m RecompileRequired -> m RecompileRequired
`recompThen` [m RecompileRequired] -> m RecompileRequired
forall (m :: * -> *).
Monad m =>
[m RecompileRequired] -> m RecompileRequired
checkList [m RecompileRequired]
checks
checkOldIface
:: HscEnv
-> ModSummary
-> Maybe ModIface
-> IO (MaybeValidated ModIface)
checkOldIface :: HscEnv
-> ModSummary -> Maybe ModIface -> IO (MaybeValidated ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
maybe_iface
= do let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
Logger -> String -> IO ()
showPass Logger
logger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Checking old interface for " String -> String -> String
forall a. [a] -> [a] -> [a]
++
(DynFlags -> Module -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (Module -> String) -> Module -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
mod_summary) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" (use -ddump-hi-diffs for more details)"
SDoc
-> HscEnv
-> IfG (MaybeValidated ModIface)
-> IO (MaybeValidated ModIface)
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"checkOldIface") HscEnv
hsc_env (IfG (MaybeValidated ModIface) -> IO (MaybeValidated ModIface))
-> IfG (MaybeValidated ModIface) -> IO (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary -> Maybe ModIface -> IfG (MaybeValidated ModIface)
check_old_iface HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
maybe_iface
check_old_iface
:: HscEnv
-> ModSummary
-> Maybe ModIface
-> IfG (MaybeValidated ModIface)
check_old_iface :: HscEnv
-> ModSummary -> Maybe ModIface -> IfG (MaybeValidated ModIface)
check_old_iface HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
maybe_iface
= let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
getIface :: IO (Maybe ModIface)
getIface =
case Maybe ModIface
maybe_iface of
Just ModIface
_ -> do
Logger -> SDoc -> IO ()
trace_if Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"We already have the old interface for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> Module
ms_mod ModSummary
mod_summary))
Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
maybe_iface
Maybe ModIface
Nothing -> DynFlags -> String -> IO (Maybe ModIface)
loadIface DynFlags
dflags (ModSummary -> String
msHiFilePath ModSummary
mod_summary)
loadIface :: DynFlags -> String -> IO (Maybe ModIface)
loadIface DynFlags
read_dflags String
iface_path = do
let ncu :: NameCache
ncu = HscEnv -> NameCache
hsc_NC HscEnv
hsc_env
read_result <- DynFlags
-> NameCache
-> Module
-> String
-> IO (MaybeErr ReadInterfaceError ModIface)
readIface DynFlags
read_dflags NameCache
ncu (ModSummary -> Module
ms_mod ModSummary
mod_summary) String
iface_path
case read_result of
Failed ReadInterfaceError
err -> do
let msg :: SDoc
msg = ReadInterfaceError -> SDoc
readInterfaceErrorDiagnostic ReadInterfaceError
err
Logger -> SDoc -> IO ()
trace_if Logger
logger
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FYI: cannot read old interface file:"
, Int -> SDoc -> SDoc
nest Int
4 SDoc
msg ]
Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Old interface file was invalid:"
, Int -> SDoc -> SDoc
nest Int
4 SDoc
msg ]
Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing
Succeeded ModIface
iface -> do
Logger -> SDoc -> IO ()
trace_if Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Read the interface file" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
iface_path)
Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModIface -> IO (Maybe ModIface))
-> Maybe ModIface -> IO (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface
check_dyn_hi :: ModIface
-> IfG (MaybeValidated ModIface)
-> IfG (MaybeValidated ModIface)
check_dyn_hi :: ModIface
-> IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface)
check_dyn_hi ModIface
normal_iface IfG (MaybeValidated ModIface)
recomp_check | GeneralFlag -> DynFlags -> AnyHpcUsage
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags = do
res <- IfG (MaybeValidated ModIface)
recomp_check
case res of
UpToDateItem ModIface
_ -> do
maybe_dyn_iface <- IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO (Maybe ModIface)
loadIface (DynFlags -> DynFlags
setDynamicNow DynFlags
dflags) (ModSummary -> String
msDynHiFilePath ModSummary
mod_summary)
case maybe_dyn_iface of
Maybe ModIface
Nothing -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingDynHiFile Maybe ModIface
forall a. Maybe a
Nothing
Just ModIface
dyn_iface | ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
dyn_iface)
Fingerprint -> Fingerprint -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
/= ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
normal_iface)
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MismatchedDynHiFile Maybe ModIface
forall a. Maybe a
Nothing
Just {} -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return MaybeValidated ModIface
res
MaybeValidated ModIface
_ -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return MaybeValidated ModIface
res
check_dyn_hi ModIface
_ IfG (MaybeValidated ModIface)
recomp_check = IfG (MaybeValidated ModIface)
recomp_check
src_changed :: AnyHpcUsage
src_changed
| GeneralFlag -> DynFlags -> AnyHpcUsage
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags = AnyHpcUsage
True
| AnyHpcUsage
otherwise = AnyHpcUsage
False
in do
AnyHpcUsage
-> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall (f :: * -> *). Applicative f => AnyHpcUsage -> f () -> f ()
when AnyHpcUsage
src_changed (IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ())
-> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$
IO () -> IOEnv (Env IfGblEnv ()) ()
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv ()) ())
-> IO () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Recompilation check turned off")
case AnyHpcUsage
src_changed of
AnyHpcUsage
True | AnyHpcUsage -> AnyHpcUsage
not (Backend -> AnyHpcUsage
backendWritesFiles (Backend -> AnyHpcUsage) -> Backend -> AnyHpcUsage
forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
dflags) ->
MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
MustCompile Maybe ModIface
maybe_iface
AnyHpcUsage
True -> do
maybe_iface' <- IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ IO (Maybe ModIface)
getIface
return $ OutOfDateItem MustCompile maybe_iface'
AnyHpcUsage
False -> do
maybe_iface' <- IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> IO (Maybe ModIface) -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ IO (Maybe ModIface)
getIface
case maybe_iface' of
Maybe ModIface
Nothing -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
MustCompile Maybe ModIface
forall a. Maybe a
Nothing
Just ModIface
iface ->
ModIface
-> IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface)
check_dyn_hi ModIface
iface (IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface))
-> IfG (MaybeValidated ModIface) -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModIface -> IfG (MaybeValidated ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
checkVersions :: HscEnv
-> ModSummary
-> ModIface
-> IfG (MaybeValidated ModIface)
checkVersions :: HscEnv -> ModSummary -> ModIface -> IfG (MaybeValidated ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
= do { IO () -> IOEnv (Env IfGblEnv ()) ()
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv ()) ())
-> IO () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Considering whether compilation is required for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
; hsc_env <- TcRnIf IfGblEnv () HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; if mi_src_hash iface /= ms_hs_hash mod_summary
then return $ outOfDateItemBecause SourceFileChanged Nothing else do {
; if not (isHomeModule home_unit (mi_module iface))
then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {
; recomp <- liftIO $ checkFlagHash hsc_env iface
`recompThen` checkOptimHash hsc_env iface
`recompThen` checkHpcHash hsc_env iface
`recompThen` checkMergedSignatures hsc_env mod_summary iface
`recompThen` checkHsig logger home_unit mod_summary iface
`recompThen` pure (checkHie dflags mod_summary)
; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe ModIface
forall a. Maybe a
Nothing ; RecompileRequired
_ -> do {
; recomp <- HscEnv
-> ModSummary
-> ModIface
-> IOEnv (Env IfGblEnv ()) RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface) ; RecompileRequired
_ -> do {
; recomp <- Plugins -> ModIface -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) ModIface
iface
; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe ModIface
forall a. Maybe a
Nothing ; RecompileRequired
_ -> do {
AnyHpcUsage
-> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall (f :: * -> *). Applicative f => AnyHpcUsage -> f () -> f ()
when (GhcMode -> AnyHpcUsage
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))) (IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ())
-> IOEnv (Env IfGblEnv ()) () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ do {
; (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env IfGblEnv ()) ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ((ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env IfGblEnv ()) ())
-> (ExternalPackageState -> ExternalPackageState)
-> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ \ExternalPackageState
eps -> ExternalPackageState
eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }
}
; recomp <- [IOEnv (Env IfGblEnv ()) RecompileRequired]
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall (m :: * -> *).
Monad m =>
[m RecompileRequired] -> m RecompileRequired
checkList [FinderCache -> Usage -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkModUsage (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) Usage
u
| Usage
u <- ModIface -> [Usage]
forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface
iface]
; case recomp of (NeedsRecompile CompileReason
reason) -> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ CompileReason -> Maybe ModIface -> MaybeValidated ModIface
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface) ; RecompileRequired
_ -> do {
; MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated ModIface -> IfG (MaybeValidated ModIface))
-> MaybeValidated ModIface -> IfG (MaybeValidated ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> MaybeValidated ModIface
forall a. a -> MaybeValidated a
UpToDateItem ModIface
iface
}}}}}}}
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger 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
checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired
checkPlugins :: Plugins -> ModIface -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkPlugins Plugins
plugins ModIface
iface = IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
recomp <- Plugins -> IO PluginRecompile
recompPlugins Plugins
plugins
let new_fingerprint = PluginRecompile -> Fingerprint
fingerprintPluginRecompile PluginRecompile
recomp
let old_fingerprint = ModIfaceBackend -> Fingerprint
mi_plugin_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp
recompPlugins :: Plugins -> IO PluginRecompile
recompPlugins :: Plugins -> IO PluginRecompile
recompPlugins Plugins
plugins = [PluginRecompile] -> PluginRecompile
forall a. Monoid a => [a] -> a
mconcat ([PluginRecompile] -> PluginRecompile)
-> IO [PluginRecompile] -> IO PluginRecompile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PluginWithArgs -> IO PluginRecompile)
-> [PluginWithArgs] -> IO [PluginRecompile]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PluginWithArgs -> IO PluginRecompile
pluginRecompile' (Plugins -> [PluginWithArgs]
pluginsWithArgs Plugins
plugins)
fingerprintPlugins :: Plugins -> IO Fingerprint
fingerprintPlugins :: Plugins -> IO Fingerprint
fingerprintPlugins Plugins
plugins = PluginRecompile -> Fingerprint
fingerprintPluginRecompile (PluginRecompile -> Fingerprint)
-> IO PluginRecompile -> IO Fingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plugins -> IO PluginRecompile
recompPlugins Plugins
plugins
fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
fingerprintPluginRecompile PluginRecompile
recomp = case PluginRecompile
recomp of
PluginRecompile
NoForceRecompile -> String -> Fingerprint
fingerprintString String
"NoForceRecompile"
PluginRecompile
ForceRecompile -> String -> Fingerprint
fingerprintString String
"ForceRecompile"
MaybeRecompile Fingerprint
fp -> Fingerprint
fp
pluginRecompileToRecompileRequired
:: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired Fingerprint
old_fp Fingerprint
new_fp PluginRecompile
pr
| Fingerprint
old_fp Fingerprint -> Fingerprint -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== Fingerprint
new_fp =
case PluginRecompile
pr of
PluginRecompile
NoForceRecompile -> RecompileRequired
UpToDate
MaybeRecompile Fingerprint
_ -> RecompileRequired
UpToDate
PluginRecompile
ForceRecompile -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
ImpurePlugin
| Fingerprint
old_fp Fingerprint -> [Fingerprint] -> AnyHpcUsage
forall a. Eq a => a -> [a] -> AnyHpcUsage
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> AnyHpcUsage
`elem` [Fingerprint]
magic_fingerprints AnyHpcUsage -> AnyHpcUsage -> AnyHpcUsage
||
Fingerprint
new_fp Fingerprint -> [Fingerprint] -> AnyHpcUsage
forall a. Eq a => a -> [a] -> AnyHpcUsage
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> AnyHpcUsage
`elem` [Fingerprint]
magic_fingerprints
= RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
PluginsChanged
| AnyHpcUsage
otherwise =
case PluginRecompile
pr of
PluginRecompile
ForceRecompile -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
PluginFingerprintChanged
PluginRecompile
_ -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
PluginFingerprintChanged
where
magic_fingerprints :: [Fingerprint]
magic_fingerprints =
[ String -> Fingerprint
fingerprintString String
"NoForceRecompile"
, String -> Fingerprint
fingerprintString String
"ForceRecompile"
]
checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired
checkHsig :: Logger
-> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired
checkHsig Logger
logger HomeUnit
home_unit ModSummary
mod_summary ModIface
iface = do
let outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
inner_mod :: Module
inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod)
AnyHpcUsage -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
AnyHpcUsage -> m ()
massert (HomeUnit -> Module -> AnyHpcUsage
isHomeModule HomeUnit
home_unit Module
outer_mod)
case Module
inner_mod Module -> Module -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_semantic_module ModIface
iface of
AnyHpcUsage
True -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"implementing module unchanged")
AnyHpcUsage
False -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
ModuleInstChanged
checkHie :: DynFlags -> ModSummary -> RecompileRequired
checkHie :: DynFlags -> ModSummary -> RecompileRequired
checkHie DynFlags
dflags ModSummary
mod_summary =
let hie_date_opt :: Maybe UTCTime
hie_date_opt = ModSummary -> Maybe UTCTime
ms_hie_date ModSummary
mod_summary
hi_date :: Maybe UTCTime
hi_date = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
mod_summary
in if AnyHpcUsage -> AnyHpcUsage
not (GeneralFlag -> DynFlags -> AnyHpcUsage
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags)
then RecompileRequired
UpToDate
else case (Maybe UTCTime
hie_date_opt, Maybe UTCTime
hi_date) of
(Maybe UTCTime
Nothing, Maybe UTCTime
_) -> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
HieMissing
(Just UTCTime
hie_date, Just UTCTime
hi_date)
| UTCTime
hie_date UTCTime -> UTCTime -> AnyHpcUsage
forall a. Ord a => a -> a -> AnyHpcUsage
< UTCTime
hi_date
-> RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
HieOutdated
(Maybe UTCTime, Maybe UTCTime)
_ -> RecompileRequired
UpToDate
checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
checkFlagHash HscEnv
hsc_env ModIface
iface = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let old_hash :: Fingerprint
old_hash = ModIfaceBackend -> Fingerprint
mi_flag_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
new_hash <- HscEnv
-> Module -> (WriteBinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintDynFlags HscEnv
hsc_env (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) WriteBinHandle -> Name -> IO ()
putNameLiterally
case old_hash == new_hash of
AnyHpcUsage
True -> Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module flags unchanged")
AnyHpcUsage
False -> Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
FlagsChanged
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Module flags have changed")
Fingerprint
old_hash Fingerprint
new_hash
checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired
checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired
checkOptimHash HscEnv
hsc_env ModIface
iface = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let old_hash :: Fingerprint
old_hash = ModIfaceBackend -> Fingerprint
mi_opt_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
new_hash <- DynFlags -> (WriteBinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintOptFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
WriteBinHandle -> Name -> IO ()
putNameLiterally
if | old_hash == new_hash
-> up_to_date logger (text "Optimisation flags unchanged")
| gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
-> up_to_date logger (text "Optimisation flags changed; ignoring")
| otherwise
-> out_of_date_hash logger OptimFlagsChanged
(text " Optimisation flags have changed")
old_hash new_hash
checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired
checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired
checkHpcHash HscEnv
hsc_env ModIface
iface = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let old_hash :: Fingerprint
old_hash = ModIfaceBackend -> Fingerprint
mi_hpc_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
new_hash <- DynFlags -> (WriteBinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintHpcFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
WriteBinHandle -> Name -> IO ()
putNameLiterally
if | old_hash == new_hash
-> up_to_date logger (text "HPC flags unchanged")
| gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
-> up_to_date logger (text "HPC flags changed; ignoring")
| otherwise
-> out_of_date_hash logger HpcFlagsChanged
(text " HPC flags have changed")
old_hash new_hash
checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
checkMergedSignatures HscEnv
hsc_env ModSummary
mod_summary ModIface
iface = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let unit_state :: UnitState
unit_state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
let old_merged :: [Module]
old_merged = [Module] -> [Module]
forall a. Ord a => [a] -> [a]
sort [ Module
mod | UsageMergedRequirement{ usg_mod :: Usage -> Module
usg_mod = Module
mod } <- ModIface -> [Usage]
forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface
iface ]
new_merged :: [Module]
new_merged = case UniqMap ModuleName [InstantiatedModule]
-> ModuleName -> Maybe [InstantiatedModule]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UniqMap ModuleName [InstantiatedModule]
requirementContext UnitState
unit_state)
(ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) of
Maybe [InstantiatedModule]
Nothing -> []
Just [InstantiatedModule]
r -> [Module] -> [Module]
forall a. Ord a => [a] -> [a]
sort ([Module] -> [Module]) -> [Module] -> [Module]
forall a b. (a -> b) -> a -> b
$ (InstantiatedModule -> Module) -> [InstantiatedModule] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> InstantiatedModule -> Module
instModuleToModule UnitState
unit_state) [InstantiatedModule]
r
if [Module]
old_merged [Module] -> [Module] -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== [Module]
new_merged
then Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"signatures to merge in unchanged" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Module]
new_merged)
else RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
SigsMergeChanged
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies :: HscEnv
-> ModSummary
-> ModIface
-> IOEnv (Env IfGblEnv ()) RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
summary ModIface
iface
= do
res_normal <- (ModuleName -> PkgQual -> IO FindResult)
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall t l.
(ModuleName -> t -> IO FindResult)
-> [(t, GenLocated l ModuleName)]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
classify_import (HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env) (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps ModSummary
summary [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
summary)
res_plugin <- classify_import (\ModuleName
mod PkgQual
_ -> FinderCache
-> FinderOpts
-> UnitState
-> Maybe HomeUnit
-> ModuleName
-> IO FindResult
findPluginModule FinderCache
fc FinderOpts
fopts UnitState
units Maybe HomeUnit
mhome_unit ModuleName
mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left CompileReason
recomp -> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
recomp
Right [Either (UnitId, ModuleName) (FastString, UnitId)]
es -> do
let ([(UnitId, ModuleName)]
hs, [(FastString, UnitId)]
ps) = [Either (UnitId, ModuleName) (FastString, UnitId)]
-> ([(UnitId, ModuleName)], [(FastString, UnitId)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (UnitId, ModuleName) (FastString, UnitId)]
es
IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$
[(UnitId, ModuleName)]
-> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods ([(UnitId, ModuleName)] -> [(UnitId, ModuleName)]
forall a. Ord a => [a] -> [a]
sort [(UnitId, ModuleName)]
hs) [(UnitId, ModuleName)]
prev_dep_mods
IO RecompileRequired
-> IO RecompileRequired -> IO RecompileRequired
forall (m :: * -> *).
Monad m =>
m RecompileRequired -> m RecompileRequired -> m RecompileRequired
`recompThen`
let allPkgDeps :: [(FastString, UnitId)]
allPkgDeps = ((FastString, UnitId) -> (FastString, UnitId) -> Ordering)
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FastString, UnitId) -> UnitId)
-> (FastString, UnitId) -> (FastString, UnitId) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FastString, UnitId) -> UnitId
forall a b. (a, b) -> b
snd) ([(FastString, UnitId)] -> [(FastString, UnitId)])
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall a b. (a -> b) -> a -> b
$ ((FastString, UnitId) -> UnitId)
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (FastString, UnitId) -> UnitId
forall a b. (a, b) -> b
snd [(FastString, UnitId)]
ps
in [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages [(FastString, UnitId)]
allPkgDeps [UnitId]
prev_dep_pkgs
where
classify_import :: (ModuleName -> t -> IO FindResult)
-> [(t, GenLocated l ModuleName)]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
classify_import :: forall t l.
(ModuleName -> t -> IO FindResult)
-> [(t, GenLocated l ModuleName)]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
classify_import ModuleName -> t -> IO FindResult
find_import [(t, GenLocated l ModuleName)]
imports =
IO
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))])
-> IO
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall a b. (a -> b) -> a -> b
$ ((t, GenLocated l ModuleName)
-> IO
(Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))))
-> [(t, GenLocated l ModuleName)]
-> IO
[Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(t
mb_pkg, L l
_ ModuleName
mod) ->
let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChanged ModuleName
mod
in RecompReason
-> FindResult
-> Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
classify RecompReason
reason (FindResult
-> Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId)))
-> IO FindResult
-> IO
(Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> t -> IO FindResult
find_import ModuleName
mod t
mb_pkg)
[(t, GenLocated l ModuleName)]
imports
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
all_home_units :: Set UnitId
all_home_units = HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env
units :: UnitState
units = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
prev_dep_mods :: [(UnitId, ModuleName)]
prev_dep_mods = ((UnitId, ModuleNameWithIsBoot) -> (UnitId, ModuleName))
-> [(UnitId, ModuleNameWithIsBoot)] -> [(UnitId, ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map ((ModuleNameWithIsBoot -> ModuleName)
-> (UnitId, ModuleNameWithIsBoot) -> (UnitId, ModuleName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod) ([(UnitId, ModuleNameWithIsBoot)] -> [(UnitId, ModuleName)])
-> [(UnitId, ModuleNameWithIsBoot)] -> [(UnitId, ModuleName)]
forall a b. (a -> b) -> a -> b
$ Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a. Set a -> [a]
Set.toAscList (Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)])
-> Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a b. (a -> b) -> a -> b
$ Dependencies -> Set (UnitId, ModuleNameWithIsBoot)
dep_direct_mods (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)
prev_dep_pkgs :: [UnitId]
prev_dep_pkgs = Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toAscList (Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Dependencies -> Set UnitId
dep_direct_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface))
(Dependencies -> Set UnitId
dep_plugin_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)))
fake_ghc_prim_import :: Either (UnitId, ModuleName) (FastString, UnitId)
fake_ghc_prim_import = case Maybe HomeUnit
mhome_unit of
Just HomeUnit
home_unit
| HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit UnitId -> UnitId -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== UnitId
primUnitId
-> (UnitId, ModuleName)
-> Either (UnitId, ModuleName) (FastString, UnitId)
forall a b. a -> Either a b
Left (UnitId
primUnitId, String -> ModuleName
mkModuleName String
"GHC.Prim")
Maybe HomeUnit
_ -> (FastString, UnitId)
-> Either (UnitId, ModuleName) (FastString, UnitId)
forall a b. b -> Either a b
Right (String -> FastString
fsLit String
"GHC.Prim", UnitId
primUnitId)
classify :: RecompReason
-> FindResult
-> Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
classify RecompReason
_ (Found ModLocation
_ Module
mod)
| (Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod) UnitId -> Set UnitId -> AnyHpcUsage
forall a. Eq a => a -> Set a -> AnyHpcUsage
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> AnyHpcUsage
`elem` Set UnitId
all_home_units = Either (UnitId, ModuleName) (FastString, UnitId)
-> Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
forall a b. b -> Either a b
Right ((UnitId, ModuleName)
-> Either (UnitId, ModuleName) (FastString, UnitId)
forall a b. a -> Either a b
Left ((Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod), Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))
| AnyHpcUsage
otherwise = Either (UnitId, ModuleName) (FastString, UnitId)
-> Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
forall a b. b -> Either a b
Right ((FastString, UnitId)
-> Either (UnitId, ModuleName) (FastString, UnitId)
forall a b. b -> Either a b
Right (ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod), Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod))
classify RecompReason
reason FindResult
_ = CompileReason
-> Either
CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))
forall a b. a -> Either a b
Left (RecompReason -> CompileReason
RecompBecause RecompReason
reason)
check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods :: [(UnitId, ModuleName)]
-> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods [] [] = RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
check_mods [] ((UnitId, ModuleName)
old:[(UnitId, ModuleName)]
_) = do
Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"module no longer" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes ((UnitId, ModuleName) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId, ModuleName)
old) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in dependencies"
RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ (UnitId, ModuleName) -> RecompReason
ModuleRemoved (UnitId, ModuleName)
old
check_mods ((UnitId, ModuleName)
new:[(UnitId, ModuleName)]
news) [(UnitId, ModuleName)]
olds
| Just ((UnitId, ModuleName)
old, [(UnitId, ModuleName)]
olds') <- [(UnitId, ModuleName)]
-> Maybe ((UnitId, ModuleName), [(UnitId, ModuleName)])
forall a. [a] -> Maybe (a, [a])
uncons [(UnitId, ModuleName)]
olds
, (UnitId, ModuleName)
new (UnitId, ModuleName) -> (UnitId, ModuleName) -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== (UnitId, ModuleName)
old = [(UnitId, ModuleName)]
-> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods (((UnitId, ModuleName) -> AnyHpcUsage)
-> [(UnitId, ModuleName)] -> [(UnitId, ModuleName)]
forall a. (a -> AnyHpcUsage) -> [a] -> [a]
dropWhile ((UnitId, ModuleName) -> (UnitId, ModuleName) -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== (UnitId, ModuleName)
new) [(UnitId, ModuleName)]
news) [(UnitId, ModuleName)]
olds'
| AnyHpcUsage
otherwise = do
Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"imported module " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
quotes ((UnitId, ModuleName) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId, ModuleName)
new) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" not among previous dependencies"
RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ (UnitId, ModuleName) -> RecompReason
ModuleAdded (UnitId, ModuleName)
new
check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages [] [] = RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
check_packages [] (UnitId
old:[UnitId]
_) = do
Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
quotes (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
old) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"no longer in dependencies"
RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ UnitId -> RecompReason
UnitDepRemoved UnitId
old
check_packages ((FastString
new_name, UnitId
new_unit):[(FastString, UnitId)]
news) [UnitId]
olds
| Just (UnitId
old, [UnitId]
olds') <- [UnitId] -> Maybe (UnitId, [UnitId])
forall a. [a] -> Maybe (a, [a])
uncons [UnitId]
olds
, UnitId
new_unit UnitId -> UnitId -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== UnitId
old = [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages (((FastString, UnitId) -> AnyHpcUsage)
-> [(FastString, UnitId)] -> [(FastString, UnitId)]
forall a. (a -> AnyHpcUsage) -> [a] -> [a]
dropWhile ((UnitId -> UnitId -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== UnitId
new_unit) (UnitId -> AnyHpcUsage)
-> ((FastString, UnitId) -> UnitId)
-> (FastString, UnitId)
-> AnyHpcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, UnitId) -> UnitId
forall a b. (a, b) -> b
snd) [(FastString, UnitId)]
news) [UnitId]
olds'
| AnyHpcUsage
otherwise = do
Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"imported package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
new_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
new_unit SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not among previous dependencies"
RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ FastString -> RecompReason
ModulePackageChanged FastString
new_name
needInterface :: Module -> (ModIface -> IO RecompileRequired)
-> IfG RecompileRequired
needInterface :: Module
-> (ModIface -> IO RecompileRequired)
-> IOEnv (Env IfGblEnv ()) RecompileRequired
needInterface Module
mod ModIface -> IO RecompileRequired
continue
= do
mb_recomp <- String -> Module -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
tryGetModIface
String
"need version info for"
Module
mod
case mb_recomp of
Maybe ModIface
Nothing -> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
MustCompile
Just ModIface
iface -> IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$ ModIface -> IO RecompileRequired
continue ModIface
iface
tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
tryGetModIface :: String -> Module -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
tryGetModIface String
doc_msg Module
mod
= do
logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
let doc_str = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
doc_msg, Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod]
liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))
mb_iface <- loadInterface doc_str mod ImportBySystem
case mb_iface of
Failed MissingInterfaceError
_ -> do
IO () -> IOEnv (Env IfGblEnv ()) ()
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv ()) ())
-> IO () -> IOEnv (Env IfGblEnv ()) ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Couldn't load interface for module", Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod])
Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing
Succeeded ModIface
iface -> Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a. a -> IOEnv (Env IfGblEnv ()) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface))
-> Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface
checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired
checkModUsage :: FinderCache -> Usage -> IOEnv (Env IfGblEnv ()) RecompileRequired
checkModUsage FinderCache
_ UsagePackageModule{
usg_mod :: Usage -> Module
usg_mod = Module
mod,
usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash } = do
logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
needInterface mod $ \ModIface
iface -> do
let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChanged (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash (ModIfaceBackend -> Fingerprint
mi_mod_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
checkModUsage FinderCache
_ UsageMergedRequirement{ usg_mod :: Usage -> Module
usg_mod = Module
mod, usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash } = do
logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
needInterface mod $ \ModIface
iface -> do
let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChangedRaw (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash (ModIfaceBackend -> Fingerprint
mi_mod_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
checkModUsage FinderCache
_ UsageHomeModuleInterface{ usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
mod_name
, usg_unit_id :: Usage -> UnitId
usg_unit_id = UnitId
uid
, usg_iface_hash :: Usage -> Fingerprint
usg_iface_hash = Fingerprint
old_mod_hash } = do
let mod :: Module
mod = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
uid)) ModuleName
mod_name
logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
needInterface mod $ \ModIface
iface -> do
let reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChangedIface ModuleName
mod_name
Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkIfaceFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash (ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
checkModUsage FinderCache
_ UsageHomeModule{
usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
mod_name,
usg_unit_id :: Usage -> UnitId
usg_unit_id = UnitId
uid,
usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash,
usg_exports :: Usage -> Maybe Fingerprint
usg_exports = Maybe Fingerprint
maybe_old_export_hash,
usg_entities :: Usage -> [(OccName, Fingerprint)]
usg_entities = [(OccName, Fingerprint)]
old_decl_hash }
= do
let mod :: Module
mod = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
uid)) ModuleName
mod_name
logger <- IOEnv (Env IfGblEnv ()) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
needInterface mod $ \ModIface
iface -> do
let
new_mod_hash :: Fingerprint
new_mod_hash = ModIfaceBackend -> Fingerprint
mi_mod_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
new_decl_hash :: OccName -> Maybe (OccName, Fingerprint)
new_decl_hash = ModIfaceBackend -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
new_export_hash :: Fingerprint
new_export_hash = ModIfaceBackend -> Fingerprint
mi_exp_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
reason :: RecompReason
reason = ModuleName -> RecompReason
ModuleChanged (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
IO RecompileRequired -> IO RecompileRequired
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
recompile <- Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
if not (recompileRequired recompile)
then return UpToDate
else checkList
[
checkMaybeHash logger reason maybe_old_export_hash new_export_hash
(text " Export list changed")
,
checkList [ checkEntityUsage logger reason new_decl_hash u
| u <- old_decl_hash]
, up_to_date logger (text " Great! The bits I use are up to date")
]
checkModUsage FinderCache
fc UsageFile{ usg_file_path :: Usage -> FastString
usg_file_path = FastString
file,
usg_file_hash :: Usage -> Fingerprint
usg_file_hash = Fingerprint
old_hash,
usg_file_label :: Usage -> Maybe String
usg_file_label = Maybe String
mlabel } =
IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a. IO a -> IOEnv (Env IfGblEnv ()) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IOEnv (Env IfGblEnv ()) RecompileRequired)
-> IO RecompileRequired
-> IOEnv (Env IfGblEnv ()) RecompileRequired
forall a b. (a -> b) -> a -> b
$
(IOException -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a. (IOException -> IO a) -> IO a -> IO a
handleIO IOException -> IO RecompileRequired
handler (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
new_hash <- FinderCache -> String -> IO Fingerprint
lookupFileCache FinderCache
fc (String -> IO Fingerprint) -> String -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
file
if (old_hash /= new_hash)
then return recomp
else return UpToDate
where
reason :: RecompReason
reason = String -> RecompReason
FileChanged (String -> RecompReason) -> String -> RecompReason
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
file
recomp :: RecompileRequired
recomp = RecompReason -> RecompileRequired
needsRecompileBecause (RecompReason -> RecompileRequired)
-> RecompReason -> RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe RecompReason -> RecompReason
forall a. a -> Maybe a -> a
fromMaybe RecompReason
reason (Maybe RecompReason -> RecompReason)
-> Maybe RecompReason -> RecompReason
forall a b. (a -> b) -> a -> b
$ (String -> RecompReason) -> Maybe String -> Maybe RecompReason
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> RecompReason
CustomReason Maybe String
mlabel
handler :: IOException -> IO RecompileRequired
handler = if AnyHpcUsage
debugIsOn
then \IOException
e -> String -> SDoc -> IO RecompileRequired -> IO RecompileRequired
forall a. String -> SDoc -> a -> a
pprTrace String
"UsageFile" (String -> SDoc
forall doc. IsLine doc => String -> doc
text (IOException -> String
forall a. Show a => a -> String
show IOException
e)) (IO RecompileRequired -> IO RecompileRequired)
-> IO RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp
else \IOException
_ -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp
checkModuleFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint :: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
| Fingerprint
new_mod_hash Fingerprint -> Fingerprint -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== Fingerprint
old_mod_hash
= Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Module fingerprint unchanged")
| AnyHpcUsage
otherwise
= Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Module fingerprint has changed")
Fingerprint
old_mod_hash Fingerprint
new_mod_hash
checkIfaceFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkIfaceFingerprint :: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkIfaceFingerprint Logger
logger RecompReason
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
| Fingerprint
new_mod_hash Fingerprint -> Fingerprint -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== Fingerprint
old_mod_hash
= Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iface fingerprint unchanged")
| AnyHpcUsage
otherwise
= Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Iface fingerprint has changed")
Fingerprint
old_mod_hash Fingerprint
new_mod_hash
checkMaybeHash
:: Logger
-> RecompReason
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IO RecompileRequired
checkMaybeHash :: Logger
-> RecompReason
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IO RecompileRequired
checkMaybeHash Logger
logger RecompReason
reason Maybe Fingerprint
maybe_old_hash Fingerprint
new_hash SDoc
doc
| Just Fingerprint
hash <- Maybe Fingerprint
maybe_old_hash, Fingerprint
hash Fingerprint -> Fingerprint -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
/= Fingerprint
new_hash
= Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason SDoc
doc Fingerprint
hash Fingerprint
new_hash
| AnyHpcUsage
otherwise
= RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
checkEntityUsage :: Logger
-> RecompReason
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IO RecompileRequired
checkEntityUsage :: Logger
-> RecompReason
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IO RecompileRequired
checkEntityUsage Logger
logger RecompReason
reason OccName -> Maybe (OccName, Fingerprint)
new_hash (OccName
name,Fingerprint
old_hash) = do
case OccName -> Maybe (OccName, Fingerprint)
new_hash OccName
name of
Maybe (OccName, Fingerprint)
Nothing -> Logger -> RecompReason -> SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
reason ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"No longer exported:", OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name])
Just (OccName
_, Fingerprint
new_hash)
| Fingerprint
new_hash Fingerprint -> Fingerprint -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== Fingerprint
old_hash
-> do Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Up to date" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash))
RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
| AnyHpcUsage
otherwise
-> Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Out of date:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name) Fingerprint
old_hash Fingerprint
new_hash
up_to_date :: Logger -> SDoc -> IO RecompileRequired
up_to_date :: Logger -> SDoc -> IO RecompileRequired
up_to_date Logger
logger SDoc
msg = Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger SDoc
msg IO () -> IO RecompileRequired -> IO RecompileRequired
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired
out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
reason SDoc
msg = Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger SDoc
msg IO () -> IO RecompileRequired -> IO RecompileRequired
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
reason)
out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
out_of_date_hash :: Logger
-> RecompReason
-> SDoc
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
out_of_date_hash Logger
logger RecompReason
reason SDoc
msg Fingerprint
old_hash Fingerprint
new_hash
= Logger -> RecompReason -> SDoc -> IO RecompileRequired
out_of_date Logger
logger RecompReason
reason ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [SDoc
msg, Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
old_hash, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->", Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash])
addFingerprints
:: HscEnv
-> PartialModIface
-> IO ModIface
addFingerprints :: HscEnv -> PartialModIface -> IO ModIface
addFingerprints HscEnv
hsc_env PartialModIface
iface0
= do
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let
decls = PartialModIface -> [IfaceDeclExts 'ModIfaceCore]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls PartialModIface
iface0
decl_warn_fn = Warnings GhcRn -> OccName -> Maybe (WarningTxt GhcRn)
forall p. Warnings p -> OccName -> Maybe (WarningTxt p)
mkIfaceDeclWarnCache (IfaceWarnings -> Warnings GhcRn
fromIfaceWarnings (IfaceWarnings -> Warnings GhcRn)
-> IfaceWarnings -> Warnings GhcRn
forall a b. (a -> b) -> a -> b
$ PartialModIface -> IfaceWarnings
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceWarnings
mi_warns PartialModIface
iface0)
export_warn_fn = Warnings GhcRn -> Name -> Maybe (WarningTxt GhcRn)
forall p. Warnings p -> Name -> Maybe (WarningTxt p)
mkIfaceExportWarnCache (IfaceWarnings -> Warnings GhcRn
fromIfaceWarnings (IfaceWarnings -> Warnings GhcRn)
-> IfaceWarnings -> Warnings GhcRn
forall a b. (a -> b) -> a -> b
$ PartialModIface -> IfaceWarnings
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceWarnings
mi_warns PartialModIface
iface0)
fix_fn = [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache (PartialModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities PartialModIface
iface0)
declABI :: IfaceDecl -> IfaceDeclABI
declABI IfaceDecl
decl = (Module
this_mod, IfaceDecl
decl, IfaceDeclExtras
extras)
where extras :: IfaceDeclExtras
extras = (OccName -> Maybe Fixity)
-> (OccName -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv Name
-> IfaceDecl
-> IfaceDeclExtras
declExtras OccName -> Maybe Fixity
fix_fn OccName -> [AnnPayload]
ann_fn OccEnv [IfaceRule]
non_orph_rules OccEnv [IfaceClsInst]
non_orph_insts
OccEnv [IfaceFamInst]
non_orph_fis OccEnv Name
top_lvl_name_env IfaceDecl
decl
top_lvl_name_env =
[(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [ (Name -> OccName
nameOccName Name
nm, Name
nm)
| IfaceId { ifName :: IfaceDecl -> Name
ifName = Name
nm } <- [IfaceDecl]
[IfaceDeclExts 'ModIfaceCore]
decls ]
edges :: [ Node OccName IfaceDeclABI ]
edges = [ IfaceDeclABI -> OccName -> [OccName] -> Node OccName IfaceDeclABI
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode IfaceDeclABI
abi (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl) [OccName]
out
| IfaceDecl
decl <- [IfaceDecl]
[IfaceDeclExts 'ModIfaceCore]
decls
, let abi :: IfaceDeclABI
abi = IfaceDecl -> IfaceDeclABI
declABI IfaceDecl
decl
, let out :: [OccName]
out = UniqSet Name -> [OccName]
localOccs (UniqSet Name -> [OccName]) -> UniqSet Name -> [OccName]
forall a b. (a -> b) -> a -> b
$ IfaceDeclABI -> UniqSet Name
freeNamesDeclABI IfaceDeclABI
abi
]
name_module Name
n = AnyHpcUsage -> SDoc -> Module -> Module
forall a. HasCallStack => AnyHpcUsage -> SDoc -> a -> a
assertPpr (Name -> AnyHpcUsage
isExternalName Name
n) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n)
localOccs =
(Name -> OccName) -> [Name] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> OccName
getParent (OccName -> OccName) -> (Name -> OccName) -> Name -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName)
([Name] -> [OccName])
-> (UniqSet Name -> [Name]) -> UniqSet Name -> [OccName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> AnyHpcUsage) -> [Name] -> [Name]
forall a. (a -> AnyHpcUsage) -> [a] -> [a]
filter ((Module -> Module -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
== Module
semantic_mod) (Module -> AnyHpcUsage) -> (Name -> Module) -> Name -> AnyHpcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Module
name_module)
([Name] -> [Name])
-> (UniqSet Name -> [Name]) -> UniqSet Name -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
where getParent :: OccName -> OccName
getParent :: OccName -> OccName
getParent OccName
occ = OccEnv OccName -> OccName -> Maybe OccName
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv OccName
parent_map OccName
occ Maybe OccName -> OccName -> OccName
forall a. Maybe a -> a -> a
`orElse` OccName
occ
parent_map :: OccEnv OccName
parent_map = (OccEnv OccName -> IfaceDecl -> OccEnv OccName)
-> OccEnv OccName -> [IfaceDecl] -> OccEnv OccName
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OccEnv OccName -> IfaceDecl -> OccEnv OccName
extend OccEnv OccName
forall a. OccEnv a
emptyOccEnv [IfaceDecl]
[IfaceDeclExts 'ModIfaceCore]
decls
where extend :: OccEnv OccName -> IfaceDecl -> OccEnv OccName
extend OccEnv OccName
env IfaceDecl
d =
OccEnv OccName -> [(OccName, OccName)] -> OccEnv OccName
forall a. OccEnv a -> [(OccName, a)] -> OccEnv a
extendOccEnvList OccEnv OccName
env [ (OccName
b,OccName
n) | OccName
b <- IfaceDecl -> [OccName]
ifaceDeclImplicitBndrs IfaceDecl
d ]
where n :: OccName
n = IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
d
groups :: [SCC IfaceDeclABI]
groups = [Node OccName IfaceDeclABI] -> [SCC IfaceDeclABI]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node OccName IfaceDeclABI]
edges
global_hash_fn = HscEnv -> ExternalPackageState -> Name -> IO Fingerprint
mkHashFun HscEnv
hsc_env ExternalPackageState
eps
mk_put_name :: OccEnv (OccName,Fingerprint)
-> WriteBinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env WriteBinHandle
bh Name
name
| Name -> AnyHpcUsage
isWiredInName Name
name = WriteBinHandle -> Name -> IO ()
putNameLiterally WriteBinHandle
bh Name
name
| AnyHpcUsage
otherwise
= AnyHpcUsage -> SDoc -> IO () -> IO ()
forall a. HasCallStack => AnyHpcUsage -> SDoc -> a -> a
assertPpr (Name -> AnyHpcUsage
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
let hash :: IO Fingerprint
hash | HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name Module -> Module -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
/= Module
semantic_mod = Name -> IO Fingerprint
global_hash_fn Name
name
| Module
semantic_mod Module -> Module -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
/= Module
this_mod
, AnyHpcUsage -> AnyHpcUsage
not (Module -> AnyHpcUsage
forall u. GenModule (GenUnit u) -> AnyHpcUsage
isHoleModule Module
semantic_mod) = Name -> IO Fingerprint
global_hash_fn Name
name
| AnyHpcUsage
otherwise = Fingerprint -> IO Fingerprint
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((OccName, Fingerprint) -> Fingerprint
forall a b. (a, b) -> b
snd (OccEnv (OccName, Fingerprint)
-> OccName -> Maybe (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv (OccName, Fingerprint)
local_env (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name)
Maybe (OccName, Fingerprint)
-> (OccName, Fingerprint) -> (OccName, Fingerprint)
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> (OccName, Fingerprint)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"urk! lookup local fingerprint"
(Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ OccEnv (OccName, Fingerprint) -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccEnv (OccName, Fingerprint)
local_env)))
in IO Fingerprint
hash IO Fingerprint -> (Fingerprint -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBinHandle -> Fingerprint -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh
fingerprint_group :: (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
fingerprint_group (OccEnv (OccName, Fingerprint)
local_env, [(Fingerprint, IfaceDecl)]
decls_w_hashes) (AcyclicSCC IfaceDeclABI
abi)
= do let hash_fn :: WriteBinHandle -> Name -> IO ()
hash_fn = OccEnv (OccName, Fingerprint) -> WriteBinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env
decl :: IfaceDecl
decl = IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi
hash <- (WriteBinHandle -> Name -> IO ()) -> IfaceDeclABI -> IO Fingerprint
forall a.
Binary a =>
(WriteBinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint WriteBinHandle -> Name -> IO ()
hash_fn IfaceDeclABI
abi
env' <- extend_hash_env local_env (hash,decl)
return (env', (hash,decl) : decls_w_hashes)
fingerprint_group (OccEnv (OccName, Fingerprint)
local_env, [(Fingerprint, IfaceDecl)]
decls_w_hashes) (CyclicSCC [IfaceDeclABI]
abis)
= do let stable_abis :: [IfaceDeclABI]
stable_abis = (IfaceDeclABI -> IfaceDeclABI -> Ordering)
-> [IfaceDeclABI] -> [IfaceDeclABI]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames [IfaceDeclABI]
abis
stable_decls :: [IfaceDecl]
stable_decls = (IfaceDeclABI -> IfaceDecl) -> [IfaceDeclABI] -> [IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map IfaceDeclABI -> IfaceDecl
abiDecl [IfaceDeclABI]
stable_abis
local_env1 <- (OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint)))
-> OccEnv (OccName, Fingerprint)
-> [(Fingerprint, IfaceDecl)]
-> IO (OccEnv (OccName, Fingerprint))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
local_env
([Fingerprint] -> [IfaceDecl] -> [(Fingerprint, IfaceDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Word64 -> Fingerprint) -> [Word64] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Fingerprint
mkRecFingerprint [Word64
0..]) [IfaceDecl]
stable_decls)
let hash_fn = OccEnv (OccName, Fingerprint) -> WriteBinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env1
hash <- computeFingerprint hash_fn stable_abis
let pairs = [Fingerprint] -> [IfaceDecl] -> [(Fingerprint, IfaceDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Word64 -> Fingerprint) -> [Word64] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint -> Word64 -> Fingerprint
bumpFingerprint Fingerprint
hash) [Word64
0..]) [IfaceDecl]
stable_decls
local_env2 <- foldM extend_hash_env local_env pairs
return (local_env2, pairs ++ decls_w_hashes)
mkRecFingerprint :: Word64 -> Fingerprint
mkRecFingerprint Word64
i = Word64 -> Word64 -> Fingerprint
Fingerprint Word64
0 Word64
i
bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
bumpFingerprint Fingerprint
fp Word64
n = [Fingerprint] -> Fingerprint
fingerprintFingerprints [ Fingerprint
fp, Word64 -> Fingerprint
mkRecFingerprint Word64
n ]
extend_hash_env :: OccEnv (OccName,Fingerprint)
-> (Fingerprint,IfaceDecl)
-> IO (OccEnv (OccName,Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
env0 (Fingerprint
hash,IfaceDecl
d) =
OccEnv (OccName, Fingerprint) -> IO (OccEnv (OccName, Fingerprint))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (((OccName, Fingerprint)
-> OccEnv (OccName, Fingerprint) -> OccEnv (OccName, Fingerprint))
-> OccEnv (OccName, Fingerprint)
-> [(OccName, Fingerprint)]
-> OccEnv (OccName, Fingerprint)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(OccName
b,Fingerprint
fp) OccEnv (OccName, Fingerprint)
env -> OccEnv (OccName, Fingerprint)
-> OccName
-> (OccName, Fingerprint)
-> OccEnv (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv (OccName, Fingerprint)
env OccName
b (OccName
b,Fingerprint
fp)) OccEnv (OccName, Fingerprint)
env0
(Fingerprint -> IfaceDecl -> [(OccName, Fingerprint)]
ifaceDeclFingerprints Fingerprint
hash IfaceDecl
d))
(local_env, decls_w_hashes) <-
foldM fingerprint_group (emptyOccEnv, []) groups
let sorted_deps :: Dependencies
sorted_deps = PartialModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps PartialModIface
iface0
let orph_mods
= (Module -> AnyHpcUsage) -> [Module] -> [Module]
forall a. (a -> AnyHpcUsage) -> [a] -> [a]
filter (Module -> Module -> AnyHpcUsage
forall a. Eq a => a -> a -> AnyHpcUsage
/= Module
this_mod)
([Module] -> [Module]) -> [Module] -> [Module]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [Module]
dep_orphs Dependencies
sorted_deps
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
orphan_hash <- computeFingerprint (mk_put_name local_env)
(map ifDFun orph_insts, orph_rules, orph_fis)
dep_hash <- computeFingerprint putNameLiterally
(dep_sig_mods (mi_deps iface0),
dep_boot_mods (mi_deps iface0),
dep_trusted_pkgs (mi_deps iface0),
dep_finsts (mi_deps iface0) )
export_hash <- computeFingerprint putNameLiterally
(mi_exports iface0,
orphan_hash,
dep_hash,
dep_orphan_hashes,
mi_trust iface0)
let sorted_decls :: [(Fingerprint, IfaceDecl)]
sorted_decls = Map OccName (Fingerprint, IfaceDecl) -> [(Fingerprint, IfaceDecl)]
forall k a. Map k a -> [a]
Map.elems (Map OccName (Fingerprint, IfaceDecl)
-> [(Fingerprint, IfaceDecl)])
-> Map OccName (Fingerprint, IfaceDecl)
-> [(Fingerprint, IfaceDecl)]
forall a b. (a -> b) -> a -> b
$ [(OccName, (Fingerprint, IfaceDecl))]
-> Map OccName (Fingerprint, IfaceDecl)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(OccName, (Fingerprint, IfaceDecl))]
-> Map OccName (Fingerprint, IfaceDecl))
-> [(OccName, (Fingerprint, IfaceDecl))]
-> Map OccName (Fingerprint, IfaceDecl)
forall a b. (a -> b) -> a -> b
$
[(IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
d, (Fingerprint, IfaceDecl)
e) | e :: (Fingerprint, IfaceDecl)
e@(Fingerprint
_, IfaceDecl
d) <- [(Fingerprint, IfaceDecl)]
decls_w_hashes]
getOcc (IfGblTopBndr Name
b) = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
b
getOcc (IfLclTopBndr IfLclName
fs IfaceType
_ IfaceIdInfo
_ IfaceIdDetails
details) =
case IfaceIdDetails
details of
IfRecSelId { ifRecSelFirstCon :: IfaceIdDetails -> Name
ifRecSelFirstCon = Name
first_con }
-> FastString -> FastString -> OccName
mkRecFieldOccFS (Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS Name
first_con) (IfLclName -> FastString
ifLclNameFS IfLclName
fs)
IfaceIdDetails
_ -> FastString -> OccName
mkVarOccFS (IfLclName -> FastString
ifLclNameFS IfLclName
fs)
binding_key (IfaceNonRec IfaceTopBndrInfo
b b
_) = OccName -> () -> IfaceBindingX () OccName
forall r b. b -> r -> IfaceBindingX r b
IfaceNonRec (IfaceTopBndrInfo -> OccName
getOcc IfaceTopBndrInfo
b) ()
binding_key (IfaceRec [(IfaceTopBndrInfo, b)]
bs) = [(OccName, ())] -> IfaceBindingX () OccName
forall r b. [(b, r)] -> IfaceBindingX r b
IfaceRec (((IfaceTopBndrInfo, b) -> (OccName, ()))
-> [(IfaceTopBndrInfo, b)] -> [(OccName, ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(IfaceTopBndrInfo
b, b
_) -> (IfaceTopBndrInfo -> OccName
getOcc IfaceTopBndrInfo
b, ())) [(IfaceTopBndrInfo, b)]
bs)
sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
sorted_extra_decls = (IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
-> IfaceBindingX () OccName)
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
-> IfaceBindingX () OccName
forall {b}.
IfaceBindingX b IfaceTopBndrInfo -> IfaceBindingX () OccName
binding_key ([IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo])
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartialModIface
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall (phase :: ModIfacePhase).
ModIface_ phase
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls PartialModIface
iface0
flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally
opt_hash <- fingerprintOptFlags dflags putNameLiterally
hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash,
mi_warns iface0,
mi_foreign iface0)
iface_hash <- computeFingerprint putNameLiterally
(mod_hash,
mi_src_hash iface0,
ann_fn (mkVarOccFS (fsLit "module")),
mi_usages iface0,
sorted_deps,
mi_hpc iface0)
let
final_iface_exts = ModIfaceBackend
{ mi_iface_hash :: Fingerprint
mi_iface_hash = Fingerprint
iface_hash
, mi_mod_hash :: Fingerprint
mi_mod_hash = Fingerprint
mod_hash
, mi_flag_hash :: Fingerprint
mi_flag_hash = Fingerprint
flag_hash
, mi_opt_hash :: Fingerprint
mi_opt_hash = Fingerprint
opt_hash
, mi_hpc_hash :: Fingerprint
mi_hpc_hash = Fingerprint
hpc_hash
, mi_plugin_hash :: Fingerprint
mi_plugin_hash = Fingerprint
plugin_hash
, mi_orphan :: AnyHpcUsage
mi_orphan = AnyHpcUsage -> AnyHpcUsage
not ( (IfaceRule -> AnyHpcUsage) -> [IfaceRule] -> AnyHpcUsage
forall (t :: * -> *) a.
Foldable t =>
(a -> AnyHpcUsage) -> t a -> AnyHpcUsage
all IfaceRule -> AnyHpcUsage
ifRuleAuto [IfaceRule]
orph_rules
AnyHpcUsage -> AnyHpcUsage -> AnyHpcUsage
&& [IfaceClsInst] -> AnyHpcUsage
forall a. [a] -> AnyHpcUsage
forall (t :: * -> *) a. Foldable t => t a -> AnyHpcUsage
null [IfaceClsInst]
orph_insts
AnyHpcUsage -> AnyHpcUsage -> AnyHpcUsage
&& [IfaceFamInst] -> AnyHpcUsage
forall a. [a] -> AnyHpcUsage
forall (t :: * -> *) a. Foldable t => t a -> AnyHpcUsage
null [IfaceFamInst]
orph_fis)
, mi_finsts :: AnyHpcUsage
mi_finsts = AnyHpcUsage -> AnyHpcUsage
not ([IfaceFamInst] -> AnyHpcUsage
forall a. [a] -> AnyHpcUsage
forall (t :: * -> *) a. Foldable t => t a -> AnyHpcUsage
null (PartialModIface -> [IfaceFamInst]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceFamInst]
mi_fam_insts PartialModIface
iface0))
, mi_exp_hash :: Fingerprint
mi_exp_hash = Fingerprint
export_hash
, mi_orphan_hash :: Fingerprint
mi_orphan_hash = Fingerprint
orphan_hash
, mi_decl_warn_fn :: OccName -> Maybe (WarningTxt GhcRn)
mi_decl_warn_fn = OccName -> Maybe (WarningTxt GhcRn)
decl_warn_fn
, mi_export_warn_fn :: Name -> Maybe (WarningTxt GhcRn)
mi_export_warn_fn = Name -> Maybe (WarningTxt GhcRn)
export_warn_fn
, mi_fix_fn :: OccName -> Maybe Fixity
mi_fix_fn = OccName -> Maybe Fixity
fix_fn
, mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn = OccEnv (OccName, Fingerprint)
-> OccName -> Maybe (OccName, Fingerprint)
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv (OccName, Fingerprint)
local_env
}
final_iface = PartialModIface
-> [(Fingerprint, IfaceDecl)]
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> ModIfaceBackend
-> ModIface
completePartialModIface PartialModIface
iface0
[(Fingerprint, IfaceDecl)]
sorted_decls Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
sorted_extra_decls ModIfaceBackend
final_iface_exts
return final_iface
where
this_mod :: Module
this_mod = PartialModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module PartialModIface
iface0
semantic_mod :: Module
semantic_mod = PartialModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_semantic_module PartialModIface
iface0
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
(OccEnv [IfaceClsInst]
non_orph_insts, [IfaceClsInst]
orph_insts) = (IfaceClsInst -> IsOrphan)
-> [IfaceClsInst] -> (OccEnv [IfaceClsInst], [IfaceClsInst])
forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap IfaceClsInst -> IsOrphan
ifInstOrph (PartialModIface -> [IfaceClsInst]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceClsInst]
mi_insts PartialModIface
iface0)
(OccEnv [IfaceRule]
non_orph_rules, [IfaceRule]
orph_rules) = (IfaceRule -> IsOrphan)
-> [IfaceRule] -> (OccEnv [IfaceRule], [IfaceRule])
forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap IfaceRule -> IsOrphan
ifRuleOrph (PartialModIface -> [IfaceRule]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceRule]
mi_rules PartialModIface
iface0)
(OccEnv [IfaceFamInst]
non_orph_fis, [IfaceFamInst]
orph_fis) = (IfaceFamInst -> IsOrphan)
-> [IfaceFamInst] -> (OccEnv [IfaceFamInst], [IfaceFamInst])
forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap IfaceFamInst -> IsOrphan
ifFamInstOrph (PartialModIface -> [IfaceFamInst]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceFamInst]
mi_fam_insts PartialModIface
iface0)
ann_fn :: OccName -> [AnnPayload]
ann_fn = [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache (PartialModIface -> [IfaceAnnotation]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
mi_anns PartialModIface
iface0)
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes HscEnv
hsc_env [Module]
mods = do
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
get_orph_hash :: Module -> IO Fingerprint
get_orph_hash Module
mod = do
iface <- HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfG ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IfG ModIface
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx
(IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall lcl.
SDoc
-> Module
-> WhereFrom
-> IfM lcl (MaybeErr MissingInterfaceError ModIface)
loadInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"getOrphanHashes") Module
mod WhereFrom
ImportBySystem
return (mi_orphan_hash (mi_final_exts iface))
(Module -> IO Fingerprint) -> [Module] -> IO [Fingerprint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Module -> IO Fingerprint
get_orph_hash [Module]
mods
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
data
= IfaceIdExtras
|
(Maybe Fixity)
[IfaceInstABI]
[AnnPayload]
[IfaceIdExtras]
|
(Maybe Fixity)
[IfaceInstABI]
[AnnPayload]
[IfaceIdExtras]
[IfExtName]
| (Maybe Fixity) [AnnPayload]
| (Maybe Fixity) [IfaceInstABI] [AnnPayload]
|
data
=
(Maybe Fixity)
[IfaceRule]
[AnnPayload]
type IfaceInstABI = IfExtName
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (Module
_, IfaceDecl
decl, IfaceDeclExtras
_) = IfaceDecl
decl
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames IfaceDeclABI
abi1 IfaceDeclABI
abi2 = IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName (IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi1) OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare`
IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName (IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi2)
freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI :: IfaceDeclABI -> UniqSet Name
freeNamesDeclABI (Module
_mod, IfaceDecl
decl, IfaceDeclExtras
extras) =
IfaceDecl -> UniqSet Name
freeNamesIfDecl IfaceDecl
decl UniqSet Name -> UniqSet Name -> UniqSet Name
`unionNameSet` IfaceDeclExtras -> UniqSet Name
freeNamesDeclExtras IfaceDeclExtras
extras
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
(IfaceIdExtras IfaceIdExtras
id_extras)
= IfaceIdExtras -> UniqSet Name
freeNamesIdExtras IfaceIdExtras
id_extras
freeNamesDeclExtras (IfaceDataExtras Maybe Fixity
_ [Name]
insts [AnnPayload]
_ [IfaceIdExtras]
subs)
= [UniqSet Name] -> UniqSet Name
unionNameSets ([Name] -> UniqSet Name
mkNameSet [Name]
insts UniqSet Name -> [UniqSet Name] -> [UniqSet Name]
forall a. a -> [a] -> [a]
: (IfaceIdExtras -> UniqSet Name)
-> [IfaceIdExtras] -> [UniqSet Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceIdExtras -> UniqSet Name
freeNamesIdExtras [IfaceIdExtras]
subs)
freeNamesDeclExtras (IfaceClassExtras Maybe Fixity
_ [Name]
insts [AnnPayload]
_ [IfaceIdExtras]
subs [Name]
defms)
= [UniqSet Name] -> UniqSet Name
unionNameSets ([UniqSet Name] -> UniqSet Name) -> [UniqSet Name] -> UniqSet Name
forall a b. (a -> b) -> a -> b
$
[Name] -> UniqSet Name
mkNameSet [Name]
insts UniqSet Name -> [UniqSet Name] -> [UniqSet Name]
forall a. a -> [a] -> [a]
: [Name] -> UniqSet Name
mkNameSet [Name]
defms UniqSet Name -> [UniqSet Name] -> [UniqSet Name]
forall a. a -> [a] -> [a]
: (IfaceIdExtras -> UniqSet Name)
-> [IfaceIdExtras] -> [UniqSet Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceIdExtras -> UniqSet Name
freeNamesIdExtras [IfaceIdExtras]
subs
freeNamesDeclExtras (IfaceSynonymExtras Maybe Fixity
_ [AnnPayload]
_)
= UniqSet Name
emptyNameSet
freeNamesDeclExtras (IfaceFamilyExtras Maybe Fixity
_ [Name]
insts [AnnPayload]
_)
= [Name] -> UniqSet Name
mkNameSet [Name]
insts
freeNamesDeclExtras IfaceDeclExtras
IfaceOtherDeclExtras
= UniqSet Name
emptyNameSet
freeNamesIdExtras :: IfaceIdExtras -> NameSet
(IdExtras Maybe Fixity
_ [IfaceRule]
rules [AnnPayload]
_) = [UniqSet Name] -> UniqSet Name
unionNameSets ((IfaceRule -> UniqSet Name) -> [IfaceRule] -> [UniqSet Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceRule -> UniqSet Name
freeNamesIfRule [IfaceRule]
rules)
instance Outputable IfaceDeclExtras where
ppr :: IfaceDeclExtras -> SDoc
ppr IfaceDeclExtras
IfaceOtherDeclExtras = SDoc
forall doc. IsOutput doc => doc
Outputable.empty
ppr (IfaceIdExtras IfaceIdExtras
extras) = IfaceIdExtras -> SDoc
ppr_id_extras IfaceIdExtras
extras
ppr (IfaceSynonymExtras Maybe Fixity
fix [AnnPayload]
anns) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns]
ppr (IfaceFamilyExtras Maybe Fixity
fix [Name]
finsts [AnnPayload]
anns) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
finsts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns]
ppr (IfaceDataExtras Maybe Fixity
fix [Name]
insts [AnnPayload]
anns [IfaceIdExtras]
stuff) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [Name] -> SDoc
ppr_insts [Name]
insts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns,
[IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff]
ppr (IfaceClassExtras Maybe Fixity
fix [Name]
insts [AnnPayload]
anns [IfaceIdExtras]
stuff [Name]
defms) =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix, [Name] -> SDoc
ppr_insts [Name]
insts, [AnnPayload] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns,
[IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff, [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
defms]
ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts :: [Name] -> SDoc
ppr_insts [Name]
_ = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<insts>"
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
[IfaceIdExtras]
stuff = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((IfaceIdExtras -> SDoc) -> [IfaceIdExtras] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map IfaceIdExtras -> SDoc
ppr_id_extras [IfaceIdExtras]
stuff)
ppr_id_extras :: IfaceIdExtras -> SDoc
(IdExtras Maybe Fixity
fix [IfaceRule]
rules [AnnPayload]
anns) = Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((IfaceRule -> SDoc) -> [IfaceRule] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map IfaceRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceRule]
rules) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((AnnPayload -> SDoc) -> [AnnPayload] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map AnnPayload -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns)
instance Binary IfaceDeclExtras where
get :: ReadBinHandle -> IO IfaceDeclExtras
get ReadBinHandle
_bh = String -> IO IfaceDeclExtras
forall a. HasCallStack => String -> a
panic String
"no get for IfaceDeclExtras"
put_ :: WriteBinHandle -> IfaceDeclExtras -> IO ()
put_ WriteBinHandle
bh (IfaceIdExtras IfaceIdExtras
extras) = do
WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1; WriteBinHandle -> IfaceIdExtras -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh IfaceIdExtras
extras
put_ WriteBinHandle
bh (IfaceDataExtras Maybe Fixity
fix [Name]
insts [AnnPayload]
anns [IfaceIdExtras]
cons) = do
WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2; WriteBinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe Fixity
fix; WriteBinHandle -> [Name] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [Name]
insts; WriteBinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [AnnPayload]
anns; WriteBinHandle -> [IfaceIdExtras] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [IfaceIdExtras]
cons
put_ WriteBinHandle
bh (IfaceClassExtras Maybe Fixity
fix [Name]
insts [AnnPayload]
anns [IfaceIdExtras]
methods [Name]
defms) = do
WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3
WriteBinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe Fixity
fix
WriteBinHandle -> [Name] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [Name]
insts
WriteBinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [AnnPayload]
anns
WriteBinHandle -> [IfaceIdExtras] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [IfaceIdExtras]
methods
WriteBinHandle -> [Name] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [Name]
defms
put_ WriteBinHandle
bh (IfaceSynonymExtras Maybe Fixity
fix [AnnPayload]
anns) = do
WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
4; WriteBinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe Fixity
fix; WriteBinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [AnnPayload]
anns
put_ WriteBinHandle
bh (IfaceFamilyExtras Maybe Fixity
fix [Name]
finsts [AnnPayload]
anns) = do
WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
5; WriteBinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe Fixity
fix; WriteBinHandle -> [Name] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [Name]
finsts; WriteBinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [AnnPayload]
anns
put_ WriteBinHandle
bh IfaceDeclExtras
IfaceOtherDeclExtras = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
6
instance Binary IfaceIdExtras where
get :: ReadBinHandle -> IO IfaceIdExtras
get ReadBinHandle
_bh = String -> IO IfaceIdExtras
forall a. HasCallStack => String -> a
panic String
"no get for IfaceIdExtras"
put_ :: WriteBinHandle -> IfaceIdExtras -> IO ()
put_ WriteBinHandle
bh (IdExtras Maybe Fixity
fix [IfaceRule]
rules [AnnPayload]
anns)= do { WriteBinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe Fixity
fix; WriteBinHandle -> [IfaceRule] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [IfaceRule]
rules; WriteBinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [AnnPayload]
anns }
declExtras :: (OccName -> Maybe Fixity)
-> (OccName -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv IfExtName
-> IfaceDecl
-> IfaceDeclExtras
OccName -> Maybe Fixity
fix_fn OccName -> [AnnPayload]
ann_fn OccEnv [IfaceRule]
rule_env OccEnv [IfaceClsInst]
inst_env OccEnv [IfaceFamInst]
fi_env OccEnv Name
dm_env IfaceDecl
decl
= case IfaceDecl
decl of
IfaceId{} -> IfaceIdExtras -> IfaceDeclExtras
IfaceIdExtras (OccName -> IfaceIdExtras
id_extras OccName
n)
IfaceData{ifCons :: IfaceDecl -> IfaceConDecls
ifCons=IfaceConDecls
cons} ->
Maybe Fixity
-> [Name] -> [AnnPayload] -> [IfaceIdExtras] -> IfaceDeclExtras
IfaceDataExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
((IfaceFamInst -> Name) -> [IfaceFamInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceFamInst -> Name
ifFamInstAxiom (OccEnv [IfaceFamInst] -> OccName -> [IfaceFamInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceFamInst]
fi_env OccName
n) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
(IfaceClsInst -> Name) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> Name
ifDFun (OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env OccName
n))
(OccName -> [AnnPayload]
ann_fn OccName
n)
((IfaceConDecl -> IfaceIdExtras)
-> [IfaceConDecl] -> [IfaceIdExtras]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> IfaceIdExtras
id_extras (OccName -> IfaceIdExtras)
-> (IfaceConDecl -> OccName) -> IfaceConDecl -> IfaceIdExtras
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall name. HasOccName name => name -> OccName
occName (Name -> OccName)
-> (IfaceConDecl -> Name) -> IfaceConDecl -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceConDecl -> Name
ifConName) (IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfaceConDecls
cons))
IfaceClass{ifBody :: IfaceDecl -> IfaceClassBody
ifBody = IfConcreteClass { ifSigs :: IfaceClassBody -> [IfaceClassOp]
ifSigs=[IfaceClassOp]
sigs, ifATs :: IfaceClassBody -> [IfaceAT]
ifATs=[IfaceAT]
ats }} ->
Maybe Fixity
-> [Name]
-> [AnnPayload]
-> [IfaceIdExtras]
-> [Name]
-> IfaceDeclExtras
IfaceClassExtras (OccName -> Maybe Fixity
fix_fn OccName
n) [Name]
insts (OccName -> [AnnPayload]
ann_fn OccName
n) [IfaceIdExtras]
meths [Name]
defms
where
insts :: [Name]
insts = ((IfaceClsInst -> Name) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> Name
ifDFun ([IfaceClsInst] -> [Name]) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((IfaceAT -> [IfaceClsInst]) -> [IfaceAT] -> [IfaceClsInst]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IfaceAT -> [IfaceClsInst]
at_extras [IfaceAT]
ats)
[IfaceClsInst] -> [IfaceClsInst] -> [IfaceClsInst]
forall a. [a] -> [a] -> [a]
++ OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env OccName
n)
meths :: [IfaceIdExtras]
meths = [OccName -> IfaceIdExtras
id_extras (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
op) | IfaceClassOp Name
op IfaceType
_ Maybe (DefMethSpec IfaceType)
_ <- [IfaceClassOp]
sigs]
defms :: [Name]
defms = [ Name
dmName
| IfaceClassOp Name
bndr IfaceType
_ (Just DefMethSpec IfaceType
_) <- [IfaceClassOp]
sigs
, let dmOcc :: OccName
dmOcc = OccName -> OccName
mkDefaultMethodOcc (Name -> OccName
nameOccName Name
bndr)
, Just Name
dmName <- [OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Name
dm_env OccName
dmOcc] ]
IfaceSynonym{} -> Maybe Fixity -> [AnnPayload] -> IfaceDeclExtras
IfaceSynonymExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
(OccName -> [AnnPayload]
ann_fn OccName
n)
IfaceFamily{} -> Maybe Fixity -> [Name] -> [AnnPayload] -> IfaceDeclExtras
IfaceFamilyExtras (OccName -> Maybe Fixity
fix_fn OccName
n)
((IfaceFamInst -> Name) -> [IfaceFamInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceFamInst -> Name
ifFamInstAxiom (OccEnv [IfaceFamInst] -> OccName -> [IfaceFamInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceFamInst]
fi_env OccName
n))
(OccName -> [AnnPayload]
ann_fn OccName
n)
IfaceDecl
_other -> IfaceDeclExtras
IfaceOtherDeclExtras
where
n :: OccName
n = IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl
id_extras :: OccName -> IfaceIdExtras
id_extras OccName
occ = Maybe Fixity -> [IfaceRule] -> [AnnPayload] -> IfaceIdExtras
IdExtras (OccName -> Maybe Fixity
fix_fn OccName
occ) (OccEnv [IfaceRule] -> OccName -> [IfaceRule]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceRule]
rule_env OccName
occ) (OccName -> [AnnPayload]
ann_fn OccName
occ)
at_extras :: IfaceAT -> [IfaceClsInst]
at_extras (IfaceAT IfaceDecl
decl Maybe IfaceType
_) = OccEnv [IfaceClsInst] -> OccName -> [IfaceClsInst]
forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [IfaceClsInst]
inst_env (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl)
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL :: forall v. OccEnv [v] -> OccName -> [v]
lookupOccEnvL OccEnv [v]
env OccName
k = OccEnv [v] -> OccName -> Maybe [v]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [v]
env OccName
k Maybe [v] -> [v] -> [v]
forall a. Maybe a -> a -> a
`orElse` []
mkOrphMap :: (decl -> IsOrphan)
-> [decl]
-> (OccEnv [decl],
[decl])
mkOrphMap :: forall decl.
(decl -> IsOrphan) -> [decl] -> (OccEnv [decl], [decl])
mkOrphMap decl -> IsOrphan
get_key [decl]
decls
= ((OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl]))
-> (OccEnv [decl], [decl]) -> [decl] -> (OccEnv [decl], [decl])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl])
go (OccEnv [decl]
forall a. OccEnv a
emptyOccEnv, []) [decl]
decls
where
go :: (OccEnv [decl], [decl]) -> decl -> (OccEnv [decl], [decl])
go (OccEnv [decl]
non_orphs, [decl]
orphs) decl
d
| NotOrphan OccName
occ <- decl -> IsOrphan
get_key decl
d
= ((decl -> [decl] -> [decl])
-> (decl -> [decl])
-> OccEnv [decl]
-> OccName
-> decl
-> OccEnv [decl]
forall a b.
(a -> b -> b) -> (a -> b) -> OccEnv b -> OccName -> a -> OccEnv b
extendOccEnv_Acc (:) decl -> [decl]
forall a. a -> [a]
Utils.singleton OccEnv [decl]
non_orphs OccName
occ decl
d, [decl]
orphs)
| AnyHpcUsage
otherwise = (OccEnv [decl]
non_orphs, decl
ddecl -> [decl] -> [decl]
forall a. a -> [a] -> [a]
:[decl]
orphs)
mkHashFun
:: HscEnv
-> ExternalPackageState
-> (Name -> IO Fingerprint)
mkHashFun :: HscEnv -> ExternalPackageState -> Name -> IO Fingerprint
mkHashFun HscEnv
hsc_env ExternalPackageState
eps Name
name
| Module -> AnyHpcUsage
forall u. GenModule (GenUnit u) -> AnyHpcUsage
isHoleModule Module
orig_mod
= Module -> IO Fingerprint
lookup (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
orig_mod))
| AnyHpcUsage
otherwise
= Module -> IO Fingerprint
lookup Module
orig_mod
where
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
hpt :: HomeUnitGraph
hpt = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
pit :: PackageIfaceTable
pit = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps
ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
occ :: OccName
occ = Name -> OccName
nameOccName Name
name
orig_mod :: Module
orig_mod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name
lookup :: Module -> IO Fingerprint
lookup Module
mod = do
AnyHpcUsage -> SDoc -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
AnyHpcUsage -> SDoc -> m ()
massertPpr (Name -> AnyHpcUsage
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
iface <- case HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hpt PackageIfaceTable
pit Module
mod of
Just ModIface
iface -> ModIface -> IO ModIface
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
Maybe ModIface
Nothing ->
HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfG ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDocContext
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IfG ModIface
forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx
(IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall gbl lcl a. TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow
(IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface))
-> IfM () (MaybeErr MissingInterfaceError ModIface)
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> IfM () (MaybeErr MissingInterfaceError ModIface)
forall lcl.
SDoc
-> Module
-> WhereFrom
-> IfM lcl (MaybeErr MissingInterfaceError ModIface)
loadInterface (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lookupVers2") Module
mod WhereFrom
ImportBySystem
return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache [IfaceAnnotation]
anns
= \OccName
n -> OccEnv [AnnPayload] -> OccName -> Maybe [AnnPayload]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [AnnPayload]
env OccName
n Maybe [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a. Maybe a -> a -> a
`orElse` []
where
pair :: IfaceAnnotation -> (OccName, [AnnPayload])
pair (IfaceAnnotation IfaceAnnTarget
target AnnPayload
value) =
(case IfaceAnnTarget
target of
NamedTarget OccName
occn -> OccName
occn
ModuleTarget Module
_ -> FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"module")
, [AnnPayload
value])
env :: OccEnv [AnnPayload]
env = ([AnnPayload] -> [AnnPayload] -> [AnnPayload])
-> [(OccName, [AnnPayload])] -> OccEnv [AnnPayload]
forall a. (a -> a -> a) -> [(OccName, a)] -> OccEnv a
mkOccEnv_C (([AnnPayload] -> [AnnPayload] -> [AnnPayload])
-> [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [AnnPayload] -> [AnnPayload] -> [AnnPayload]
forall a. [a] -> [a] -> [a]
(++)) ((IfaceAnnotation -> (OccName, [AnnPayload]))
-> [IfaceAnnotation] -> [(OccName, [AnnPayload])]
forall a b. (a -> b) -> [a] -> [b]
map IfaceAnnotation -> (OccName, [AnnPayload])
pair [IfaceAnnotation]
anns)