{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}

-- | Module for detecting if recompilation is required
module GHC.Iface.Recomp
   ( checkOldIface
   , RecompileRequired(..)
   , recompileRequired
   , addFingerprints
   )
where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )

import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
import GHC.Iface.Load
import GHC.Iface.Recomp.Flags

import GHC.Core
import GHC.Tc.Utils.Monad
import GHC.Hs

import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Data.FastString

import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils hiding ( eqListBy )
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception

import GHC.Types.Annotations
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
import GHC.Types.SourceFile

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.Function
import Data.List (find, sortBy, sort)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)

--Qualified import so we can define a Semigroup instance
-- but it doesn't clash with Outputable.<>
import qualified Data.Semigroup

{-
  -----------------------------------------------
          Recompilation checking
  -----------------------------------------------

A complete description of how recompilation checking works can be
found in the wiki commentary:

 https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance

Please read the above page for a top-down description of how this all
works.  Notes below cover specific issues related to the implementation.

Basic idea:

  * In the mi_usages information in an interface, we record the
    fingerprint of each free variable of the module

  * In mkIface, we compute the fingerprint of each exported thing A.f.
    For each external thing that A.f refers to, we include the fingerprint
    of the external reference when computing the fingerprint of A.f.  So
    if anything that A.f depends on changes, then A.f's fingerprint will
    change.
    Also record any dependent files added with
      * addDependentFile
      * #include
      * -optP-include

  * In checkOldIface we compare the mi_usages for the module with
    the actual fingerprint for all each thing recorded in mi_usages
-}

data RecompileRequired
  = UpToDate
       -- ^ everything is up to date, recompilation is not required
  | MustCompile
       -- ^ The .hs file has been touched, or the .o/.hi file does not exist
  | RecompBecause String
       -- ^ The .o/.hi files are up to date, but something else has changed
       -- to force recompilation; the String says what (one-line summary)
   deriving RecompileRequired -> RecompileRequired -> Bool
(RecompileRequired -> RecompileRequired -> Bool)
-> (RecompileRequired -> RecompileRequired -> Bool)
-> Eq RecompileRequired
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecompileRequired -> RecompileRequired -> Bool
$c/= :: RecompileRequired -> RecompileRequired -> Bool
== :: RecompileRequired -> RecompileRequired -> Bool
$c== :: RecompileRequired -> RecompileRequired -> Bool
Eq

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

recompileRequired :: RecompileRequired -> Bool
recompileRequired :: RecompileRequired -> Bool
recompileRequired RecompileRequired
UpToDate = Bool
False
recompileRequired RecompileRequired
_ = Bool
True

-- | Top level function to check if the version of an old interface file
-- is equivalent to the current source file the user asked us to compile.
-- If the same, we can avoid recompilation. We return a tuple where the
-- first element is a bool saying if we should recompile the object file
-- and the second is maybe the interface file, where Nothing means to
-- rebuild the interface file and not use the existing one.
checkOldIface
  :: HscEnv
  -> ModSummary
  -> SourceModified
  -> Maybe ModIface         -- Old interface from compilation manager, if any
  -> IO (RecompileRequired, Maybe ModIface)

checkOldIface :: HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary SourceModified
source_modified 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 -> DynFlags -> String -> IO ()
showPass Logger
logger DynFlags
dflags (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 (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface)
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
text String
"checkOldIface") HscEnv
hsc_env (IfG (RecompileRequired, Maybe ModIface)
 -> IO (RecompileRequired, Maybe ModIface))
-> IfG (RecompileRequired, Maybe ModIface)
-> IO (RecompileRequired, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$
            HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IfG (RecompileRequired, Maybe ModIface)
check_old_iface HscEnv
hsc_env ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
maybe_iface

check_old_iface
  :: HscEnv
  -> ModSummary
  -> SourceModified
  -> Maybe ModIface
  -> IfG (RecompileRequired, Maybe ModIface)

check_old_iface :: HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IfG (RecompileRequired, Maybe ModIface)
check_old_iface HscEnv
hsc_env ModSummary
mod_summary SourceModified
src_modified Maybe ModIface
maybe_iface
  = let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        getIface :: IOEnv (Env IfGblEnv ()) (Maybe ModIface)
getIface =
            case Maybe ModIface
maybe_iface of
                Just ModIface
_  -> do
                    SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"We already have the old interface for" SDoc -> SDoc -> SDoc
<+>
                      Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModSummary -> Module
ms_mod ModSummary
mod_summary))
                    Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
maybe_iface
                Maybe ModIface
Nothing -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
loadIface

        loadIface :: IOEnv (Env IfGblEnv ()) (Maybe ModIface)
loadIface = do
             let iface_path :: String
iface_path = ModSummary -> String
msHiFilePath ModSummary
mod_summary
             MaybeErr SDoc ModIface
read_result <- Module -> String -> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall gbl lcl.
Module -> String -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)
readIface (ModSummary -> Module
ms_mod ModSummary
mod_summary) String
iface_path
             case MaybeErr SDoc ModIface
read_result of
                 Failed SDoc
err -> do
                     SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"FYI: cannot read old interface file:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
err)
                     SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (String -> SDoc
text String
"Old interface file was invalid:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
err)
                     Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing
                 Succeeded ModIface
iface -> do
                     SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"Read the interface file" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
iface_path)
                     Maybe ModIface -> IOEnv (Env IfGblEnv ()) (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (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

        src_changed :: Bool
src_changed
            | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) = Bool
True
            | SourceModified
SourceModified <- SourceModified
src_modified = Bool
True
            | Bool
otherwise = Bool
False
    in do
        Bool -> TcRnIf IfGblEnv () () -> TcRnIf IfGblEnv () ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
src_changed (TcRnIf IfGblEnv () () -> TcRnIf IfGblEnv () ())
-> TcRnIf IfGblEnv () () -> TcRnIf IfGblEnv () ()
forall a b. (a -> b) -> a -> b
$
            SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Source file changed or recompilation check turned off")

        case Bool
src_changed of
            -- If the source has changed and we're in interactive mode,
            -- avoid reading an interface; just return the one we might
            -- have been supplied with.
            Bool
True | Bool -> Bool
not (Backend -> Bool
backendProducesObject (Backend -> Bool) -> Backend -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
dflags) ->
                (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
MustCompile, Maybe ModIface
maybe_iface)

            -- Try and read the old interface for the current module
            -- from the .hi file left from the last time we compiled it
            Bool
True -> do
                Maybe ModIface
maybe_iface' <- IOEnv (Env IfGblEnv ()) (Maybe ModIface)
getIface
                (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
MustCompile, Maybe ModIface
maybe_iface')

            Bool
False -> do
                Maybe ModIface
maybe_iface' <- IOEnv (Env IfGblEnv ()) (Maybe ModIface)
getIface
                case Maybe ModIface
maybe_iface' of
                    -- We can't retrieve the iface
                    Maybe ModIface
Nothing    -> (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
MustCompile, Maybe ModIface
forall a. Maybe a
Nothing)

                    -- We have got the old iface; check its versions
                    -- even in the SourceUnmodifiedAndStable case we
                    -- should check versions because some packages
                    -- might have changed or gone away.
                    Just ModIface
iface -> HscEnv
-> ModSummary
-> ModIface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface

-- | Check if a module is still the same 'version'.
--
-- This function is called in the recompilation checker after we have
-- determined that the module M being checked hasn't had any changes
-- to its source file since we last compiled M. So at this point in general
-- two things may have changed that mean we should recompile M:
--   * The interface export by a dependency of M has changed.
--   * The compiler flags specified this time for M have changed
--     in a manner that is significant for recompilation.
-- We return not just if we should recompile the object file but also
-- if we should rebuild the interface file.
checkVersions :: HscEnv
              -> ModSummary
              -> ModIface       -- Old interface
              -> IfG (RecompileRequired, Maybe ModIface)
checkVersions :: HscEnv
-> ModSummary
-> ModIface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
  = do { SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (String -> SDoc
text String
"Considering whether compilation is required for" SDoc -> SDoc -> SDoc
<+>
                        Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) SDoc -> SDoc -> SDoc
<> SDoc
colon)

       -- readIface will have verified that the UnitId matches,
       -- but we ALSO must make sure the instantiation matches up.  See
       -- test case bkpcabal04!
       ; if Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface))
            then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
"-this-unit-id changed", Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures ModSummary
mod_summary ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- ModSummary -> ModIface -> IfG RecompileRequired
checkHsig ModSummary
mod_summary ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- ModSummary -> IfG RecompileRequired
checkHie ModSummary
mod_summary
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface) else do {
       ; RecompileRequired
recomp <- HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins HscEnv
hsc_env ModIface
iface
       ; if RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp then (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, Maybe ModIface
forall a. Maybe a
Nothing) else do {


       -- Source code unchanged and no errors yet... carry on
       --
       -- First put the dependent-module info, read from the old
       -- interface, into the envt, so that when we look for
       -- interfaces we look for the right one (.hi or .hi-boot)
       --
       -- It's just temporary because either the usage check will succeed
       -- (in which case we are done with this module) or it'll fail (in which
       -- case we'll compile the module from scratch anyhow).
       --
       -- We do this regardless of compilation mode, although in --make mode
       -- all the dependent modules should be in the HPT already, so it's
       -- quite redundant
       ; (ExternalPackageState -> ExternalPackageState)
-> TcRnIf IfGblEnv () ()
forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ((ExternalPackageState -> ExternalPackageState)
 -> TcRnIf IfGblEnv () ())
-> (ExternalPackageState -> ExternalPackageState)
-> TcRnIf IfGblEnv () ()
forall a b. (a -> b) -> a -> b
$ \ExternalPackageState
eps  -> ExternalPackageState
eps { eps_is_boot :: ModuleNameEnv ModuleNameWithIsBoot
eps_is_boot = ModuleNameEnv ModuleNameWithIsBoot
mod_deps }
       ; RecompileRequired
recomp <- [IfG RecompileRequired] -> IfG RecompileRequired
checkList [Unit -> Usage -> IfG RecompileRequired
checkModUsage (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) Usage
u
                             | Usage
u <- ModIface -> [Usage]
forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages ModIface
iface]
       ; (RecompileRequired, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface)
    }}}}}}}}}}
  where
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
    -- This is a bit of a hack really
    mod_deps :: ModuleNameEnv ModuleNameWithIsBoot
    mod_deps :: ModuleNameEnv ModuleNameWithIsBoot
mod_deps = [ModuleNameWithIsBoot] -> ModuleNameEnv ModuleNameWithIsBoot
mkModDeps (Dependencies -> [ModuleNameWithIsBoot]
dep_mods (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface))

-- | Check if any plugins are requesting recompilation
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins HscEnv
hsc_env ModIface
iface = IO RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IfG RecompileRequired)
-> IO RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ do
  Fingerprint
new_fingerprint <- HscEnv -> IO Fingerprint
fingerprintPlugins HscEnv
hsc_env
  let old_fingerprint :: Fingerprint
old_fingerprint = ModIfaceBackend -> Fingerprint
mi_plugin_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface)
  PluginRecompile
pr <- [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)
mapM PluginWithArgs -> IO PluginRecompile
pluginRecompile' (HscEnv -> [PluginWithArgs]
plugins HscEnv
hsc_env)
  RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$
    Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired Fingerprint
old_fingerprint Fingerprint
new_fingerprint PluginRecompile
pr

fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins HscEnv
hsc_env =
  [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' ([PluginWithArgs] -> IO Fingerprint)
-> [PluginWithArgs] -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ HscEnv -> [PluginWithArgs]
plugins HscEnv
hsc_env

fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' [PluginWithArgs]
plugins = do
  PluginRecompile
res <- [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)
mapM PluginWithArgs -> IO PluginRecompile
pluginRecompile' [PluginWithArgs]
plugins
  Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ case PluginRecompile
res of
      PluginRecompile
NoForceRecompile -> String -> Fingerprint
fingerprintString String
"NoForceRecompile"
      PluginRecompile
ForceRecompile   -> String -> Fingerprint
fingerprintString String
"ForceRecompile"
      -- is the chance of collision worth worrying about?
      -- An alternative is to fingerprintFingerprints [fingerprintString
      -- "maybeRecompile", fp]
      (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 -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_fp =
    case PluginRecompile
pr of
      PluginRecompile
NoForceRecompile  -> RecompileRequired
UpToDate

      -- we already checked the fingerprint above so a mismatch is not possible
      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
      MaybeRecompile Fingerprint
_  -> RecompileRequired
UpToDate

      -- when we have an impure plugin in the stack we have to unconditionally
      -- recompile since it might integrate all sorts of crazy IO results into
      -- its compilation output.
      PluginRecompile
ForceRecompile    -> String -> RecompileRequired
RecompBecause String
"Impure plugin forced recompilation"

  | Fingerprint
old_fp Fingerprint -> [Fingerprint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Fingerprint]
magic_fingerprints Bool -> Bool -> Bool
||
    Fingerprint
new_fp Fingerprint -> [Fingerprint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Fingerprint]
magic_fingerprints
    -- The fingerprints do not match either the old or new one is a magic
    -- fingerprint. This happens when non-pure plugins are added for the first
    -- time or when we go from one recompilation strategy to another: (force ->
    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
    --
    -- For example when we go from ForceRecomp to NoForceRecomp
    -- recompilation is triggered since the old impure plugins could have
    -- changed the build output which is now back to normal.
    = String -> RecompileRequired
RecompBecause String
"Plugins changed"

  | Bool
otherwise =
    let reason :: String
reason = String
"Plugin fingerprint changed" in
    case PluginRecompile
pr of
      -- even though a plugin is forcing recompilation the fingerprint changed
      -- which would cause recompilation anyways so we report the fingerprint
      -- change instead.
      PluginRecompile
ForceRecompile   -> String -> RecompileRequired
RecompBecause String
reason

      PluginRecompile
_                -> String -> RecompileRequired
RecompBecause String
reason

 where
   magic_fingerprints :: [Fingerprint]
magic_fingerprints =
       [ String -> Fingerprint
fingerprintString String
"NoForceRecompile"
       , String -> Fingerprint
fingerprintString String
"ForceRecompile"
       ]


-- | Check if an hsig file needs recompilation because its
-- implementing module has changed.
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
checkHsig ModSummary
mod_summary ModIface
iface = do
    HscEnv
hsc_env <- TcRnIf IfGblEnv () HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
    let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        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)
    MASSERT( isHomeModule home_unit outer_mod )
    case Module
inner_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_semantic_module ModIface
iface of
        Bool
True -> SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"implementing module unchanged")
        Bool
False -> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
"implementing module changed")

-- | Check if @.hie@ file is out of date or missing.
checkHie :: ModSummary -> IfG RecompileRequired
checkHie :: ModSummary -> IfG RecompileRequired
checkHie ModSummary
mod_summary = do
    DynFlags
dflags <- IOEnv (Env IfGblEnv ()) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let hie_date_opt :: Maybe UTCTime
hie_date_opt = ModSummary -> Maybe UTCTime
ms_hie_date ModSummary
mod_summary
        hs_date :: UTCTime
hs_date = ModSummary -> UTCTime
ms_hs_date ModSummary
mod_summary
    RecompileRequired -> IfG RecompileRequired
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecompileRequired -> IfG RecompileRequired)
-> RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ case GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags of
               Bool
False -> RecompileRequired
UpToDate
               Bool
True -> case Maybe UTCTime
hie_date_opt of
                           Maybe UTCTime
Nothing -> String -> RecompileRequired
RecompBecause String
"HIE file is missing"
                           Just UTCTime
hie_date
                               | UTCTime
hie_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
hs_date
                               -> String -> RecompileRequired
RecompBecause String
"HIE file is out of date"
                               | Bool
otherwise
                               -> RecompileRequired
UpToDate

-- | Check the flags haven't changed
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash HscEnv
hsc_env ModIface
iface = do
    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)
    Fingerprint
new_hash <- IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint)
-> IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintDynFlags HscEnv
hsc_env
                                             (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface)
                                             BinHandle -> Name -> IO ()
putNameLiterally
    case Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash of
        Bool
True  -> SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"Module flags unchanged")
        Bool
False -> String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
"flags changed"
                     (String -> SDoc
text String
"  Module flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- | Check the optimisation flags haven't changed
checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash HscEnv
hsc_env ModIface
iface = do
    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)
    Fingerprint
new_hash <- IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint)
-> IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall a b. (a -> b) -> a -> b
$ DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintOptFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                               BinHandle -> Name -> IO ()
putNameLiterally
    if | Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash
         -> SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"Optimisation flags unchanged")
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreOptimChanges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
         -> SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"Optimisation flags changed; ignoring")
       | Bool
otherwise
         -> String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
"Optimisation flags changed"
                     (String -> SDoc
text String
"  Optimisation flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- | Check the HPC flags haven't changed
checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash HscEnv
hsc_env ModIface
iface = do
    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)
    Fingerprint
new_hash <- IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint)
-> IO Fingerprint -> IOEnv (Env IfGblEnv ()) Fingerprint
forall a b. (a -> b) -> a -> b
$ DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintHpcFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                               BinHandle -> Name -> IO ()
putNameLiterally
    if | Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
new_hash
         -> SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"HPC flags unchanged")
       | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreHpcChanges (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
         -> SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"HPC flags changed; ignoring")
       | Bool
otherwise
         -> String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
"HPC flags changed"
                     (String -> SDoc
text String
"  HPC flags have changed")
                     Fingerprint
old_hash Fingerprint
new_hash

-- Check that the set of signatures we are merging in match.
-- If the -unit-id flags change, this can change too.
checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures ModSummary
mod_summary ModIface
iface = do
    UnitState
unit_state <- HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> TcRnIf IfGblEnv () HscEnv -> IOEnv (Env IfGblEnv ()) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf IfGblEnv () HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
    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 ModuleName
-> Map ModuleName [InstantiatedModule]
-> Maybe [InstantiatedModule]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary)
                                     (UnitState -> Map ModuleName [InstantiatedModule]
requirementContext UnitState
unit_state) 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] -> Bool
forall a. Eq a => a -> a -> Bool
== [Module]
new_merged
        then SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"signatures to merge in unchanged" SDoc -> SDoc -> SDoc
$$ [Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Module]
new_merged)
        else RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
"signatures to merge in changed")

-- If the direct imports of this module are resolved to targets that
-- are not among the dependencies of the previous interface file,
-- then we definitely need to recompile.  This catches cases like
--   - an exposed package has been upgraded
--   - we are compiling with different package flags
--   - a home module that was shadowing a package module has been removed
--   - a new home module has been added that shadows a package module
-- See bug #1372.
--
-- In addition, we also check if the union of dependencies of the imported
-- modules has any difference to the previous set of dependencies. We would need
-- to recompile in that case also since the `mi_deps` field of ModIface needs
-- to be updated to match that information. This is one of the invariants
-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).
-- See bug #16511.
--
-- Returns (RecompBecause <textual reason>) if recompilation is required.
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies HscEnv
hsc_env ModSummary
summary ModIface
iface
 =
   [IfG RecompileRequired] -> IfG RecompileRequired
checkList ([IfG RecompileRequired] -> IfG RecompileRequired)
-> [IfG RecompileRequired] -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$
     [ [IfG RecompileRequired] -> IfG RecompileRequired
checkList (((Maybe FastString, GenLocated SrcSpan ModuleName)
 -> IfG RecompileRequired)
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [IfG RecompileRequired]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FastString, GenLocated SrcSpan ModuleName)
-> IfG RecompileRequired
dep_missing (ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_imps ModSummary
summary [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps ModSummary
summary))
     , do
         (RecompileRequired
recomp, [[ModuleName]]
mnames_seen) <- [IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])]
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [[ModuleName]])
forall {m :: * -> *} {a}.
Monad m =>
[m (RecompileRequired, a)] -> m (RecompileRequired, [a])
runUntilRecompRequired ([IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])]
 -> IOEnv (Env IfGblEnv ()) (RecompileRequired, [[ModuleName]]))
-> [IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])]
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [[ModuleName]])
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan ModuleName
 -> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName]))
-> [GenLocated SrcSpan ModuleName]
-> [IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])]
forall a b. (a -> b) -> [a] -> [b]
map
           GenLocated SrcSpan ModuleName
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
checkForNewHomeDependency
           (ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
summary)
         case RecompileRequired
recomp of
           RecompileRequired
UpToDate -> do
             let
               seen_home_deps :: Set ModuleName
seen_home_deps = [Set ModuleName] -> Set ModuleName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set ModuleName] -> Set ModuleName)
-> [Set ModuleName] -> Set ModuleName
forall a b. (a -> b) -> a -> b
$ ([ModuleName] -> Set ModuleName)
-> [[ModuleName]] -> [Set ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList [[ModuleName]]
mnames_seen
             Set ModuleName -> IfG RecompileRequired
checkIfAllOldHomeDependenciesAreSeen Set ModuleName
seen_home_deps
           RecompileRequired
_ -> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp]
 where
   prev_dep_mods :: [ModuleNameWithIsBoot]
prev_dep_mods = Dependencies -> [ModuleNameWithIsBoot]
dep_mods (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)
   prev_dep_plgn :: [ModuleName]
prev_dep_plgn = Dependencies -> [ModuleName]
dep_plgins (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)
   prev_dep_pkgs :: [(UnitId, Bool)]
prev_dep_pkgs = Dependencies -> [(UnitId, Bool)]
dep_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface)
   home_unit :: HomeUnit
home_unit     = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env

   dep_missing :: (Maybe FastString, GenLocated SrcSpan ModuleName)
-> IfG RecompileRequired
dep_missing (Maybe FastString
mb_pkg, L SrcSpan
_ ModuleName
mod) = do
     FindResult
find_res <- IO FindResult -> IOEnv (Env IfGblEnv ()) FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> IOEnv (Env IfGblEnv ()) FindResult)
-> IO FindResult -> IOEnv (Env IfGblEnv ()) FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod (Maybe FastString
mb_pkg)
     let reason :: String
reason = ModuleName -> String
moduleNameString ModuleName
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed"
     case FindResult
find_res of
        Found ModLocation
_ Module
mod
          | HomeUnit -> Unit -> Bool
isHomeUnit HomeUnit
home_unit Unit
pkg
           -> if Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (ModuleNameWithIsBoot -> ModuleName)
-> [ModuleNameWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod [ModuleNameWithIsBoot]
prev_dep_mods [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
prev_dep_plgn
                 then do SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (SDoc -> TcRnIf IfGblEnv () ()) -> SDoc -> TcRnIf IfGblEnv () ()
forall a b. (a -> b) -> a -> b
$
                           String -> SDoc
text String
"imported module " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<>
                           String -> SDoc
text String
" not among previous dependencies"
                         RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
reason)
                 else
                         RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
          | Bool
otherwise
           -> if Unit -> UnitId
toUnitId Unit
pkg UnitId -> [UnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (((UnitId, Bool) -> UnitId) -> [(UnitId, Bool)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, Bool) -> UnitId
forall a b. (a, b) -> a
fst [(UnitId, Bool)]
prev_dep_pkgs)
                 then do SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (SDoc -> TcRnIf IfGblEnv () ()) -> SDoc -> TcRnIf IfGblEnv () ()
forall a b. (a -> b) -> a -> b
$
                           String -> SDoc
text String
"imported module " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<>
                           String -> SDoc
text String
" is from package " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
pkg) SDoc -> SDoc -> SDoc
<>
                           String -> SDoc
text String
", which is not among previous dependencies"
                         RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
reason)
                 else
                         RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
           where pkg :: Unit
pkg = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
        FindResult
_otherwise  -> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
reason)

   projectNonBootNames :: [GenWithIsBoot b] -> [b]
projectNonBootNames = (GenWithIsBoot b -> b) -> [GenWithIsBoot b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map GenWithIsBoot b -> b
forall mod. GenWithIsBoot mod -> mod
gwib_mod ([GenWithIsBoot b] -> [b])
-> ([GenWithIsBoot b] -> [GenWithIsBoot b])
-> [GenWithIsBoot b]
-> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenWithIsBoot b -> Bool) -> [GenWithIsBoot b] -> [GenWithIsBoot b]
forall a. (a -> Bool) -> [a] -> [a]
filter ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot) (IsBootInterface -> Bool)
-> (GenWithIsBoot b -> IsBootInterface) -> GenWithIsBoot b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot b -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot)
   old_deps :: Set ModuleName
old_deps = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList
     ([ModuleName] -> Set ModuleName) -> [ModuleName] -> Set ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleNameWithIsBoot] -> [ModuleName]
forall {b}. [GenWithIsBoot b] -> [b]
projectNonBootNames [ModuleNameWithIsBoot]
prev_dep_mods
   isOldHomeDeps :: ModuleName -> Bool
isOldHomeDeps = (ModuleName -> Set ModuleName -> Bool)
-> Set ModuleName -> ModuleName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set ModuleName
old_deps
   checkForNewHomeDependency :: GenLocated SrcSpan ModuleName
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
checkForNewHomeDependency (L SrcSpan
_ ModuleName
mname) = do
     let
       mod :: Module
mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mname
       str_mname :: String
str_mname = ModuleName -> String
moduleNameString ModuleName
mname
       reason :: String
reason = String
str_mname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed"
     -- We only want to look at home modules to check if any new home dependency
     -- pops in and thus here, skip modules that are not home. Checking
     -- membership in old home dependencies suffice because the `dep_missing`
     -- check already verified that all imported home modules are present there.
     if Bool -> Bool
not (ModuleName -> Bool
isOldHomeDeps ModuleName
mname)
       then (RecompileRequired, [ModuleName])
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
UpToDate, [])
       else do
         Maybe (RecompileRequired, [ModuleName])
mb_result <- String
-> Module
-> (ModIface
    -> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName]))
-> IfG (Maybe (RecompileRequired, [ModuleName]))
forall a. String -> Module -> (ModIface -> IfG a) -> IfG (Maybe a)
getFromModIface String
"need mi_deps for" Module
mod ((ModIface
  -> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName]))
 -> IfG (Maybe (RecompileRequired, [ModuleName])))
-> (ModIface
    -> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName]))
-> IfG (Maybe (RecompileRequired, [ModuleName]))
forall a b. (a -> b) -> a -> b
$ \ModIface
imported_iface -> do
           let mnames :: [ModuleName]
mnames = ModuleName
mnameModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:((ModuleNameWithIsBoot -> ModuleName)
-> [ModuleNameWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ([ModuleNameWithIsBoot] -> [ModuleName])
-> [ModuleNameWithIsBoot] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (ModuleNameWithIsBoot -> Bool)
-> [ModuleNameWithIsBoot] -> [ModuleNameWithIsBoot]
forall a. (a -> Bool) -> [a] -> [a]
filter ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot) (IsBootInterface -> Bool)
-> (ModuleNameWithIsBoot -> IsBootInterface)
-> ModuleNameWithIsBoot
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameWithIsBoot -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot) ([ModuleNameWithIsBoot] -> [ModuleNameWithIsBoot])
-> [ModuleNameWithIsBoot] -> [ModuleNameWithIsBoot]
forall a b. (a -> b) -> a -> b
$
                 Dependencies -> [ModuleNameWithIsBoot]
dep_mods (Dependencies -> [ModuleNameWithIsBoot])
-> Dependencies -> [ModuleNameWithIsBoot]
forall a b. (a -> b) -> a -> b
$ ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
imported_iface)
           case (ModuleName -> Bool) -> [ModuleName] -> Maybe ModuleName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not (Bool -> Bool) -> (ModuleName -> Bool) -> ModuleName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Bool
isOldHomeDeps) [ModuleName]
mnames of
             Maybe ModuleName
Nothing -> (RecompileRequired, [ModuleName])
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
UpToDate, [ModuleName]
mnames)
             Just ModuleName
new_dep_mname -> do
               SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (SDoc -> TcRnIf IfGblEnv () ()) -> SDoc -> TcRnIf IfGblEnv () ()
forall a b. (a -> b) -> a -> b
$
                 String -> SDoc
text String
"imported home module " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<>
                 String -> SDoc
text String
" has a new dependency " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
new_dep_mname)
               (RecompileRequired, [ModuleName])
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
reason, [])
         (RecompileRequired, [ModuleName])
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
forall (m :: * -> *) a. Monad m => a -> m a
return ((RecompileRequired, [ModuleName])
 -> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName]))
-> (RecompileRequired, [ModuleName])
-> IOEnv (Env IfGblEnv ()) (RecompileRequired, [ModuleName])
forall a b. (a -> b) -> a -> b
$ (RecompileRequired, [ModuleName])
-> Maybe (RecompileRequired, [ModuleName])
-> (RecompileRequired, [ModuleName])
forall a. a -> Maybe a -> a
fromMaybe (RecompileRequired
MustCompile, []) Maybe (RecompileRequired, [ModuleName])
mb_result

   -- Performs all recompilation checks in the list until a check that yields
   -- recompile required is encountered. Returns the list of the results of
   -- all UpToDate checks.
   runUntilRecompRequired :: [m (RecompileRequired, a)] -> m (RecompileRequired, [a])
runUntilRecompRequired []             = (RecompileRequired, [a]) -> m (RecompileRequired, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
UpToDate, [])
   runUntilRecompRequired (m (RecompileRequired, a)
check:[m (RecompileRequired, a)]
checks) = do
     (RecompileRequired
recompile, a
value) <- m (RecompileRequired, a)
check
     if RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile
       then (RecompileRequired, [a]) -> m (RecompileRequired, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recompile, [])
       else do
         (RecompileRequired
recomp, [a]
values) <- [m (RecompileRequired, a)] -> m (RecompileRequired, [a])
runUntilRecompRequired [m (RecompileRequired, a)]
checks
         (RecompileRequired, [a]) -> m (RecompileRequired, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired
recomp, a
valuea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
values)

   checkIfAllOldHomeDependenciesAreSeen :: Set ModuleName -> IfG RecompileRequired
checkIfAllOldHomeDependenciesAreSeen Set ModuleName
seen_deps = do
     let unseen_old_deps :: Set ModuleName
unseen_old_deps = Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference
          Set ModuleName
old_deps
          Set ModuleName
seen_deps
     if Bool -> Bool
not (Set ModuleName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set ModuleName
unseen_old_deps)
       then do
         let missing_dep :: ModuleName
missing_dep = Int -> Set ModuleName -> ModuleName
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set ModuleName
unseen_old_deps
         SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (SDoc -> TcRnIf IfGblEnv () ()) -> SDoc -> TcRnIf IfGblEnv () ()
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"missing old home dependency " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
missing_dep)
         RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IfG RecompileRequired)
-> RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ String -> RecompileRequired
RecompBecause String
"missing old dependency"
       else RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate

needInterface :: Module -> (ModIface -> IfG RecompileRequired)
             -> IfG RecompileRequired
needInterface :: Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ModIface -> IfG RecompileRequired
continue
  = do
      Maybe RecompileRequired
mb_recomp <- String
-> Module
-> (ModIface -> IfG RecompileRequired)
-> IfG (Maybe RecompileRequired)
forall a. String -> Module -> (ModIface -> IfG a) -> IfG (Maybe a)
getFromModIface
        String
"need version info for"
        Module
mod
        ModIface -> IfG RecompileRequired
continue
      case Maybe RecompileRequired
mb_recomp of
        Maybe RecompileRequired
Nothing -> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
MustCompile
        Just RecompileRequired
recomp -> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp

getFromModIface :: String -> Module -> (ModIface -> IfG a)
              -> IfG (Maybe a)
getFromModIface :: forall a. String -> Module -> (ModIface -> IfG a) -> IfG (Maybe a)
getFromModIface String
doc_msg Module
mod ModIface -> IfG a
getter
  = do  -- Load the imported interface if possible
    let doc_str :: SDoc
doc_str = [SDoc] -> SDoc
sep [String -> SDoc
text String
doc_msg, Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod]
    SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (String -> SDoc
text String
"Checking innterface for module" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)

    MaybeErr SDoc ModIface
mb_iface <- SDoc
-> Module
-> WhereFrom
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall lcl.
SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface SDoc
doc_str Module
mod WhereFrom
ImportBySystem
        -- Load the interface, but don't complain on failure;
        -- Instead, get an Either back which we can test

    case MaybeErr SDoc ModIface
mb_iface of
      Failed SDoc
_ -> do
        SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs ([SDoc] -> SDoc
sep [String -> SDoc
text String
"Couldn't load interface for module",
                           Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod])
        Maybe a -> IfG (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                  -- Couldn't find or parse a module mentioned in the
                  -- old interface file.  Don't complain: it might
                  -- just be that the current module doesn't need that
                  -- import and it's been deleted
      Succeeded ModIface
iface -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IfG a -> IfG (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModIface -> IfG a
getter ModIface
iface

-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
checkModUsage :: Unit -> Usage -> IfG RecompileRequired
checkModUsage :: Unit -> Usage -> IfG RecompileRequired
checkModUsage Unit
_this_pkg UsagePackageModule{
                                usg_mod :: Usage -> Module
usg_mod = Module
mod,
                                usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash }
  = Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ((ModIface -> IfG RecompileRequired) -> IfG RecompileRequired)
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ \ModIface
iface -> do
    let reason :: String
reason = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed"
    String -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint String
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))
        -- We only track the ABI hash of package modules, rather than
        -- individual entity usages, so if the ABI hash changes we must
        -- recompile.  This is safe but may entail more recompilation when
        -- a dependent package has changed.

checkModUsage Unit
_ UsageMergedRequirement{ usg_mod :: Usage -> Module
usg_mod = Module
mod, usg_mod_hash :: Usage -> Fingerprint
usg_mod_hash = Fingerprint
old_mod_hash }
  = Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ((ModIface -> IfG RecompileRequired) -> IfG RecompileRequired)
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ \ModIface
iface -> do
    let reason :: String
reason = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed (raw)"
    String -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint String
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 Unit
this_pkg UsageHomeModule{
                                usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
mod_name,
                                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 Unit
this_pkg ModuleName
mod_name
    Module
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
needInterface Module
mod ((ModIface -> IfG RecompileRequired) -> IfG RecompileRequired)
-> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ \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 :: String
reason = ModuleName -> String
moduleNameString ModuleName
mod_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed"

           -- CHECK MODULE
       RecompileRequired
recompile <- String -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint String
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
       if Bool -> Bool
not (RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile)
         then RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
         else
           -- CHECK EXPORT LIST
           String
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IfG RecompileRequired
-> IfG RecompileRequired
checkMaybeHash String
reason Maybe Fingerprint
maybe_old_export_hash Fingerprint
new_export_hash
               (String -> SDoc
text String
"  Export list changed") (IfG RecompileRequired -> IfG RecompileRequired)
-> IfG RecompileRequired -> IfG RecompileRequired
forall a b. (a -> b) -> a -> b
$ do

                 -- CHECK ITEMS ONE BY ONE
                 RecompileRequired
recompile <- [IfG RecompileRequired] -> IfG RecompileRequired
checkList [ String
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG RecompileRequired
checkEntityUsage String
reason OccName -> Maybe (OccName, Fingerprint)
new_decl_hash (OccName, Fingerprint)
u
                                        | (OccName, Fingerprint)
u <- [(OccName, Fingerprint)]
old_decl_hash]
                 if RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile
                   then RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recompile     -- This one failed, so just bail out now
                   else SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"  Great!  The bits I use are up to date")


checkModUsage Unit
_this_pkg UsageFile{ usg_file_path :: Usage -> String
usg_file_path = String
file,
                                   usg_file_hash :: Usage -> Fingerprint
usg_file_hash = Fingerprint
old_hash } =
  IO RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecompileRequired -> IfG RecompileRequired)
-> IO RecompileRequired -> IfG 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
      Fingerprint
new_hash <- String -> IO Fingerprint
getFileHash String
file
      if (Fingerprint
old_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
new_hash)
         then RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp
         else RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
 where
   recomp :: RecompileRequired
recomp  = String -> RecompileRequired
RecompBecause (String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" changed")
   handler :: IOException -> IO RecompileRequired
handler =
#if defined(DEBUG)
       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
#else
       \IOException
_ -> RecompileRequired -> IO RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recomp -- if we can't find the file, just recompile, don't fail
#endif

------------------------
checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
                       -> IfG RecompileRequired
checkModuleFingerprint :: String -> Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint String
reason Fingerprint
old_mod_hash Fingerprint
new_mod_hash
  | Fingerprint
new_mod_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_mod_hash
  = SDoc -> IfG RecompileRequired
up_to_date (String -> SDoc
text String
"Module fingerprint unchanged")

  | Bool
otherwise
  = String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
reason (String -> SDoc
text String
"  Module fingerprint has changed")
                     Fingerprint
old_mod_hash Fingerprint
new_mod_hash

------------------------
checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
               -> IfG RecompileRequired -> IfG RecompileRequired
checkMaybeHash :: String
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IfG RecompileRequired
-> IfG RecompileRequired
checkMaybeHash String
reason Maybe Fingerprint
maybe_old_hash Fingerprint
new_hash SDoc
doc IfG RecompileRequired
continue
  | Just Fingerprint
hash <- Maybe Fingerprint
maybe_old_hash, Fingerprint
hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint
new_hash
  = String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
reason SDoc
doc Fingerprint
hash Fingerprint
new_hash
  | Bool
otherwise
  = IfG RecompileRequired
continue

------------------------
checkEntityUsage :: String
                 -> (OccName -> Maybe (OccName, Fingerprint))
                 -> (OccName, Fingerprint)
                 -> IfG RecompileRequired
checkEntityUsage :: String
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG RecompileRequired
checkEntityUsage String
reason OccName -> Maybe (OccName, Fingerprint)
new_hash (OccName
name,Fingerprint
old_hash)
  = case OccName -> Maybe (OccName, Fingerprint)
new_hash OccName
name of

        Maybe (OccName, Fingerprint)
Nothing       ->        -- We used it before, but it ain't there now
                          String -> SDoc -> IfG RecompileRequired
out_of_date String
reason ([SDoc] -> SDoc
sep [String -> SDoc
text String
"No longer exported:", OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name])

        Just (OccName
_, Fingerprint
new_hash)      -- It's there, but is it up to date?
          | Fingerprint
new_hash Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
old_hash -> do SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs (String -> SDoc
text String
"  Up to date" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash))
                                       RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
          | Bool
otherwise            -> String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
reason (String -> SDoc
text String
"  Out of date:" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name)
                                                     Fingerprint
old_hash Fingerprint
new_hash

up_to_date :: SDoc -> IfG RecompileRequired
up_to_date :: SDoc -> IfG RecompileRequired
up_to_date  SDoc
msg = SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs SDoc
msg TcRnIf IfGblEnv () ()
-> IfG RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate

out_of_date :: String -> SDoc -> IfG RecompileRequired
out_of_date :: String -> SDoc -> IfG RecompileRequired
out_of_date String
reason SDoc
msg = SDoc -> TcRnIf IfGblEnv () ()
forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs SDoc
msg TcRnIf IfGblEnv () ()
-> IfG RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RecompileRequired
RecompBecause String
reason)

out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash :: String
-> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash String
reason SDoc
msg Fingerprint
old_hash Fingerprint
new_hash
  = String -> SDoc -> IfG RecompileRequired
out_of_date String
reason ([SDoc] -> SDoc
hsep [SDoc
msg, Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
old_hash, String -> SDoc
text String
"->", Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
new_hash])

----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
checkList []             = RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
checkList (IfG RecompileRequired
check:[IfG RecompileRequired]
checks) = do RecompileRequired
recompile <- IfG RecompileRequired
check
                              if RecompileRequired -> Bool
recompileRequired RecompileRequired
recompile
                                then RecompileRequired -> IfG RecompileRequired
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
recompile
                                else [IfG RecompileRequired] -> IfG RecompileRequired
checkList [IfG RecompileRequired]
checks


-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface

{-
Note [Fingerprinting IfaceDecls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The general idea here is that we first examine the 'IfaceDecl's and determine
the recursive groups of them. We then walk these groups in dependency order,
serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
hash using MD5 to produce a fingerprint for the group.

However, the serialization that we use is a bit funny: we override the @putName@
operation with our own which serializes the hash of a 'Name' instead of the
'Name' itself. This ensures that the fingerprint of a decl changes if anything
in its transitive closure changes. This trick is why we must be careful about
traversing in dependency order: we need to ensure that we have hashes for
everything referenced by the decl which we are fingerprinting.

Moreover, we need to be careful to distinguish between serialization of binding
Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
field of a IfaceClsInst): only in the non-binding case should we include the
fingerprint; in the binding case we shouldn't since it is merely the name of the
thing that we are currently fingerprinting.


Note [Fingerprinting recursive groups]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The fingerprinting of a single recursive group is a rather subtle affair, as
seen in #18733.

How not to fingerprint
----------------------

Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a
group in hash environment `hash_env0`:

 1. extend hash_env0, giving each declaration in the group the fingerprint 0
 2. use this environment to hash the declarations' ABIs, resulting in
    group_fingerprint
 3. produce the final hash environment by extending hash_env0, mapping each
    declaration of the group to group_fingerprint

However, this is wrong. Consider, for instance, a program like:

    data A = ARecu B | ABase String deriving (Show)
    data B = BRecu A | BBase Int deriving (Show)

    info :: B
    info = BBase 1

A consequence of (3) is that A and B will have the same fingerprint. This means
that if the user changes `info` to:

    info :: A
    info = ABase "hello"

The program's ABI fingerprint will not change despite `info`'s type, and
therefore ABI, being clearly different.

However, the incorrectness doesn't end there: (1) means that all recursive
occurrences of names within the group will be given the same fingerprint. This
means that the group's fingerprint won't change if we change an occurrence of A
to B.

Surprisingly, this bug (#18733) lurked for many years before being uncovered.

How we now fingerprint
----------------------

As seen above, the fingerprinting function must ensure that a groups
fingerprint captures the structure of within-group occurrences. The scheme that
we use is:

 0. To ensure determinism, sort the declarations into a stable order by
    declaration name

 1. Extend hash_env0, giving each declaration in the group a sequential
    fingerprint (e.g. 0, 1, 2, ...).

 2. Use this environment to hash the declarations' ABIs, resulting in
    group_fingerprint.

    Since we included the sequence number in step (1) programs identical up to
    transposition of recursive occurrences are distinguisable, avoiding the
    second issue mentioned above.

 3. Produce the final environment by extending hash_env, mapping each
    declaration of the group to the hash of (group_fingerprint, i), where
    i is the position of the declaration in the stable ordering.

    Including i in the hash ensures that the first issue noted above is
    avoided.

-}

-- | Add fingerprints for top-level declarations to a 'ModIface'.
--
-- See Note [Fingerprinting IfaceDecls]
addFingerprints
        :: HscEnv
        -> PartialModIface
        -> IO ModIface
addFingerprints :: HscEnv -> PartialModIface -> IO ModIface
addFingerprints HscEnv
hsc_env PartialModIface
iface0
 = do
   ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
   let
       decls :: [IfaceDeclExts 'ModIfaceCore]
decls = PartialModIface -> [IfaceDeclExts 'ModIfaceCore]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
mi_decls PartialModIface
iface0
       warn_fn :: OccName -> Maybe WarningTxt
warn_fn = Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache (PartialModIface -> Warnings
forall (phase :: ModIfacePhase). ModIface_ phase -> Warnings
mi_warns PartialModIface
iface0)
       fix_fn :: OccName -> Maybe Fixity
fix_fn = [(OccName, Fixity)] -> OccName -> Maybe Fixity
mkIfaceFixCache (PartialModIface -> [(OccName, Fixity)]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [(OccName, Fixity)]
mi_fixities PartialModIface
iface0)

        -- The ABI of a declaration represents everything that is made
        -- visible about the declaration that a client can depend on.
        -- see IfaceDeclABI below.
       declABI :: IfaceDecl -> IfaceDeclABI
       -- TODO: I'm not sure if this should be semantic_mod or this_mod.
       -- See also Note [Identity versus semantic module]
       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

       -- This is used for looking up the Name of a default method
       -- from its OccName. See Note [default method Name]
       top_lvl_name_env :: OccEnv Name
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 ]

       -- Dependency edges between declarations in the current module.
       -- This is computed by finding the free external names of each
       -- declaration, including IfaceDeclExtras (things that a
       -- declaration implicitly depends on).
       edges :: [ Node Unique IfaceDeclABI ]
       edges :: [Node Unique IfaceDeclABI]
edges = [ IfaceDeclABI -> Unique -> [Unique] -> Node Unique IfaceDeclABI
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode IfaceDeclABI
abi (OccName -> Unique
forall a. Uniquable a => a -> Unique
getUnique (IfaceDecl -> OccName
forall a. NamedThing a => a -> OccName
getOccName IfaceDecl
decl)) [Unique]
out
               | IfaceDecl
decl <- [IfaceDecl]
[IfaceDeclExts 'ModIfaceCore]
decls
               , let abi :: IfaceDeclABI
abi = IfaceDecl -> IfaceDeclABI
declABI IfaceDecl
decl
               , let out :: [Unique]
out = UniqSet Name -> [Unique]
localOccs (UniqSet Name -> [Unique]) -> UniqSet Name -> [Unique]
forall a b. (a -> b) -> a -> b
$ IfaceDeclABI -> UniqSet Name
freeNamesDeclABI IfaceDeclABI
abi
               ]

       name_module :: Name -> Module
name_module Name
n = ASSERT2( isExternalName n, ppr n ) nameModule n
       localOccs :: UniqSet Name -> [Unique]
localOccs =
         (Name -> Unique) -> [Name] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> Unique
forall a. Uniquable a => a -> Unique
getUnique (OccName -> Unique) -> (Name -> OccName) -> Name -> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
                        -- NB: names always use semantic module, so
                        -- filtering must be on the semantic module!
                        -- See Note [Identity versus semantic module]
                        ([Name] -> [Unique])
-> (UniqSet Name -> [Name]) -> UniqSet Name -> [Unique]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
semantic_mod) (Module -> Bool) -> (Name -> Module) -> Name -> Bool
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
                   -- It's OK to use nonDetEltsUFM as localOccs is only
                   -- used to construct the edges and
                   -- stronglyConnCompFromEdgedVertices is deterministic
                   -- even with non-deterministic order of edges as
                   -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
          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

        -- maps OccNames to their parents in the current module.
        -- e.g. a reference to a constructor must be turned into a reference
        -- to the TyCon for the purposes of calculating dependencies.
       parent_map :: OccEnv OccName
       parent_map :: OccEnv OccName
parent_map = (OccEnv OccName -> IfaceDecl -> OccEnv OccName)
-> OccEnv OccName -> [IfaceDecl] -> OccEnv OccName
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

        -- Strongly-connected groups of declarations, in dependency order
       groups :: [SCC IfaceDeclABI]
       groups :: [SCC IfaceDeclABI]
groups = [Node Unique IfaceDeclABI] -> [SCC IfaceDeclABI]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Unique IfaceDeclABI]
edges

       global_hash_fn :: Name -> IO Fingerprint
global_hash_fn = HscEnv -> ExternalPackageState -> Name -> IO Fingerprint
mkHashFun HscEnv
hsc_env ExternalPackageState
eps

        -- How to output Names when generating the data to fingerprint.
        -- Here we want to output the fingerprint for each top-level
        -- Name, whether it comes from the current module or another
        -- module.  In this way, the fingerprint for a declaration will
        -- change if the fingerprint for anything it refers to (transitively)
        -- changes.
       mk_put_name :: OccEnv (OccName,Fingerprint)
                   -> BinHandle -> Name -> IO  ()
       mk_put_name :: OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env BinHandle
bh Name
name
          | Name -> Bool
isWiredInName Name
name  =  BinHandle -> Name -> IO ()
putNameLiterally BinHandle
bh Name
name
           -- wired-in names don't have fingerprints
          | Bool
otherwise
          = ASSERT2( isExternalName name, ppr name )
            let hash :: IO Fingerprint
hash | HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
semantic_mod =  Name -> IO Fingerprint
global_hash_fn Name
name
                     -- Get it from the REAL interface!!
                     -- This will trigger when we compile an hsig file
                     -- and we know a backing impl for it.
                     -- See Note [Identity versus semantic module]
                     | Module
semantic_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
this_mod
                     , Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
semantic_mod) = Name -> IO Fingerprint
global_hash_fn Name
name
                     | Bool
otherwise = Fingerprint -> IO Fingerprint
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
$$ OccEnv (OccName, Fingerprint) -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccEnv (OccName, Fingerprint)
local_env)))
                -- This panic indicates that we got the dependency
                -- analysis wrong, because we needed a fingerprint for
                -- an entity that wasn't in the environment.  To debug
                -- it, turn the panic into a trace, uncomment the
                -- pprTraces below, run the compile again, and inspect
                -- the output and the generated .hi file with
                -- --show-iface.
            in IO Fingerprint
hash IO Fingerprint -> (Fingerprint -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh

        -- take a strongly-connected group of declarations and compute
        -- its fingerprint.

       fingerprint_group :: (OccEnv (OccName,Fingerprint),
                             [(Fingerprint,IfaceDecl)])
                         -> SCC IfaceDeclABI
                         -> IO (OccEnv (OccName,Fingerprint),
                                [(Fingerprint,IfaceDecl)])

       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 :: BinHandle -> Name -> IO ()
hash_fn = OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env
                   decl :: IfaceDecl
decl = IfaceDeclABI -> IfaceDecl
abiDecl IfaceDeclABI
abi
               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
               Fingerprint
hash <- (BinHandle -> Name -> IO ()) -> IfaceDeclABI -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
hash_fn IfaceDeclABI
abi
               OccEnv (OccName, Fingerprint)
env' <- OccEnv (OccName, Fingerprint)
-> (Fingerprint, IfaceDecl) -> IO (OccEnv (OccName, Fingerprint))
extend_hash_env OccEnv (OccName, Fingerprint)
local_env (Fingerprint
hash,IfaceDecl
decl)
               (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
forall (m :: * -> *) a. Monad m => a -> m a
return (OccEnv (OccName, Fingerprint)
env', (Fingerprint
hash,IfaceDecl
decl) (Fingerprint, IfaceDecl)
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. a -> [a] -> [a]
: [(Fingerprint, IfaceDecl)]
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
               OccEnv (OccName, Fingerprint)
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)
                -- See Note [Fingerprinting recursive groups]
               let hash_fn :: BinHandle -> Name -> IO ()
hash_fn = OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env1
               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
                -- put the cycle in a canonical order
               Fingerprint
hash <- (BinHandle -> Name -> IO ()) -> [IfaceDeclABI] -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
hash_fn [IfaceDeclABI]
stable_abis
               let pairs :: [(Fingerprint, IfaceDecl)]
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
                -- See Note [Fingerprinting recursive groups]
               OccEnv (OccName, Fingerprint)
local_env2 <- (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)]
pairs
               (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
forall (m :: * -> *) a. Monad m => a -> m a
return (OccEnv (OccName, Fingerprint)
local_env2, [(Fingerprint, IfaceDecl)]
pairs [(Fingerprint, IfaceDecl)]
-> [(Fingerprint, IfaceDecl)] -> [(Fingerprint, IfaceDecl)]
forall a. [a] -> [a] -> [a]
++ [(Fingerprint, IfaceDecl)]
decls_w_hashes)

       -- Make a fingerprint from the ordinal position of a binding in its group.
       mkRecFingerprint :: Word64 -> Fingerprint
       mkRecFingerprint :: Word64 -> Fingerprint
mkRecFingerprint Word64
i = Word64 -> Word64 -> Fingerprint
Fingerprint Word64
0 Word64
i

       bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
       bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
bumpFingerprint Fingerprint
fp Word64
n = [Fingerprint] -> Fingerprint
fingerprintFingerprints [ Fingerprint
fp, Word64 -> Fingerprint
mkRecFingerprint Word64
n ]

       -- we have fingerprinted the whole declaration, but we now need
       -- to assign fingerprints to all the OccNames that it binds, to
       -- use when referencing those OccNames in later declarations.
       --
       extend_hash_env :: OccEnv (OccName,Fingerprint)
                       -> (Fingerprint,IfaceDecl)
                       -> IO (OccEnv (OccName,Fingerprint))
       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 (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 (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))

   --
   (OccEnv (OccName, Fingerprint)
local_env, [(Fingerprint, IfaceDecl)]
decls_w_hashes) <-
       ((OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
 -> SCC IfaceDeclABI
 -> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)]))
-> (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> [SCC IfaceDeclABI]
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName, Fingerprint), [(Fingerprint, IfaceDecl)])
fingerprint_group (OccEnv (OccName, Fingerprint)
forall a. OccEnv a
emptyOccEnv, []) [SCC IfaceDeclABI]
groups

   -- when calculating fingerprints, we always need to use canonical
   -- ordering for lists of things.  In particular, the mi_deps has various
   -- lists of modules and suchlike, so put these all in canonical order:
   let sorted_deps :: Dependencies
       sorted_deps :: Dependencies
sorted_deps = Dependencies -> Dependencies
sortDependencies (PartialModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps PartialModIface
iface0)

   -- The export hash of a module depends on the orphan hashes of the
   -- orphan modules below us in the dependency tree.  This is the way
   -- that changes in orphans get propagated all the way up the
   -- dependency tree.
   --
   -- Note [A bad dep_orphs optimization]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   -- In a previous version of this code, we filtered out orphan modules which
   -- were not from the home package, justifying it by saying that "we'd
   -- pick up the ABI hashes of the external module instead".  This is wrong.
   -- Suppose that we have:
   --
   --       module External where
   --           instance Show (a -> b)
   --
   --       module Home1 where
   --           import External
   --
   --       module Home2 where
   --           import Home1
   --
   -- The export hash of Home1 needs to reflect the orphan instances of
   -- External. It's true that Home1 will get rebuilt if the orphans
   -- of External, but we also need to make sure Home2 gets rebuilt
   -- as well.  See #12733 for more details.
   let orph_mods :: [Module]
orph_mods
        = (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
this_mod) -- Note [Do not update EPS with your own hi-boot]
        ([Module] -> [Module]) -> [Module] -> [Module]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [Module]
dep_orphs Dependencies
sorted_deps
   [Fingerprint]
dep_orphan_hashes <- HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes HscEnv
hsc_env [Module]
orph_mods

   -- Note [Do not update EPS with your own hi-boot]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   -- (See also #10182).  When your hs-boot file includes an orphan
   -- instance declaration, you may find that the dep_orphs of a module you
   -- import contains reference to yourself.  DO NOT actually load this module
   -- or add it to the orphan hashes: you're going to provide the orphan
   -- instances yourself, no need to consult hs-boot; if you do load the
   -- interface into EPS, you will see a duplicate orphan instance.

   Fingerprint
orphan_hash <- (BinHandle -> Name -> IO ())
-> ([Name], [IfaceRule], [IfaceFamInst]) -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint (OccEnv (OccName, Fingerprint) -> BinHandle -> Name -> IO ()
mk_put_name OccEnv (OccName, Fingerprint)
local_env)
                                     ((IfaceClsInst -> Name) -> [IfaceClsInst] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceClsInst -> Name
ifDFun [IfaceClsInst]
orph_insts, [IfaceRule]
orph_rules, [IfaceFamInst]
orph_fis)

   -- the export list hash doesn't depend on the fingerprints of
   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
   Fingerprint
export_hash <- (BinHandle -> Name -> IO ())
-> ([IfaceExport], Fingerprint, [Fingerprint], [(UnitId, Bool)],
    [Module], IfaceTrustInfo)
-> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
putNameLiterally
                      (PartialModIface -> [IfaceExport]
forall (phase :: ModIfacePhase). ModIface_ phase -> [IfaceExport]
mi_exports PartialModIface
iface0,
                       Fingerprint
orphan_hash,
                       [Fingerprint]
dep_orphan_hashes,
                       Dependencies -> [(UnitId, Bool)]
dep_pkgs (PartialModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps PartialModIface
iface0),
                       -- See Note [Export hash depends on non-orphan family instances]
                       Dependencies -> [Module]
dep_finsts (PartialModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps PartialModIface
iface0),
                        -- dep_pkgs: see "Package Version Changes" on
                        -- wiki/commentary/compiler/recompilation-avoidance
                       PartialModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust PartialModIface
iface0)
                        -- Make sure change of Safe Haskell mode causes recomp.

   -- Note [Export hash depends on non-orphan family instances]
   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   --
   -- Suppose we have:
   --
   --   module A where
   --       type instance F Int = Bool
   --
   --   module B where
   --       import A
   --
   --   module C where
   --       import B
   --
   -- The family instance consistency check for C depends on the dep_finsts of
   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need
   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
   -- the exports of B, because C always considers them when checking
   -- consistency.
   --
   -- A full discussion is in #12723.
   --
   -- We do NOT need to hash dep_orphs, because this is implied by
   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
   -- because there is no eager consistency check as there is with type families
   -- (also we didn't store it anywhere!)
   --

   -- put the declarations in a canonical order, sorted by OccName
   let sorted_decls :: [(Fingerprint, IfaceDecl)]
       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]

   -- the flag hash depends on:
   --   - (some of) dflags
   -- it returns two hashes, one that shouldn't change
   -- the abi hash and one that should
   Fingerprint
flag_hash <- HscEnv -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintDynFlags HscEnv
hsc_env Module
this_mod BinHandle -> Name -> IO ()
putNameLiterally

   Fingerprint
opt_hash <- DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintOptFlags DynFlags
dflags BinHandle -> Name -> IO ()
putNameLiterally

   Fingerprint
hpc_hash <- DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintHpcFlags DynFlags
dflags BinHandle -> Name -> IO ()
putNameLiterally

   Fingerprint
plugin_hash <- HscEnv -> IO Fingerprint
fingerprintPlugins HscEnv
hsc_env

   -- the ABI hash depends on:
   --   - decls
   --   - export list
   --   - orphans
   --   - deprecations
   --   - flag abi hash
   Fingerprint
mod_hash <- (BinHandle -> Name -> IO ())
-> ([Fingerprint], Fingerprint, Warnings) -> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
putNameLiterally
                      (((Fingerprint, IfaceDecl) -> Fingerprint)
-> [(Fingerprint, IfaceDecl)] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint, IfaceDecl) -> Fingerprint
forall a b. (a, b) -> a
fst [(Fingerprint, IfaceDecl)]
sorted_decls,
                       Fingerprint
export_hash,  -- includes orphan_hash
                       PartialModIface -> Warnings
forall (phase :: ModIfacePhase). ModIface_ phase -> Warnings
mi_warns PartialModIface
iface0)

   -- The interface hash depends on:
   --   - the ABI hash, plus
   --   - the module level annotations,
   --   - usages
   --   - deps (home and external packages, dependent files)
   --   - hpc
   Fingerprint
iface_hash <- (BinHandle -> Name -> IO ())
-> (Fingerprint, [AnnPayload], [Usage], Dependencies, Bool)
-> IO Fingerprint
forall a.
Binary a =>
(BinHandle -> Name -> IO ()) -> a -> IO Fingerprint
computeFingerprint BinHandle -> Name -> IO ()
putNameLiterally
                      (Fingerprint
mod_hash,
                       OccName -> [AnnPayload]
ann_fn (String -> OccName
mkVarOcc String
"module"),  -- See mkIfaceAnnCache
                       PartialModIface -> [Usage]
forall (phase :: ModIfacePhase). ModIface_ phase -> [Usage]
mi_usages PartialModIface
iface0,
                       Dependencies
sorted_deps,
                       PartialModIface -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_hpc PartialModIface
iface0)

   let
    final_iface_exts :: ModIfaceBackend
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 :: Bool
mi_orphan      = Bool -> Bool
not (   (IfaceRule -> Bool) -> [IfaceRule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all IfaceRule -> Bool
ifRuleAuto [IfaceRule]
orph_rules
                                   -- See Note [Orphans and auto-generated rules]
                              Bool -> Bool -> Bool
&& [IfaceClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceClsInst]
orph_insts
                              Bool -> Bool -> Bool
&& [IfaceFamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IfaceFamInst]
orph_fis)
      , mi_finsts :: Bool
mi_finsts      = Bool -> Bool
not ([IfaceFamInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
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_warn_fn :: OccName -> Maybe WarningTxt
mi_warn_fn     = OccName -> Maybe WarningTxt
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 :: ModIface
final_iface = PartialModIface
iface0 { mi_decls :: [IfaceDeclExts 'ModIfaceFinal]
mi_decls = [(Fingerprint, IfaceDecl)]
[IfaceDeclExts 'ModIfaceFinal]
sorted_decls, mi_final_exts :: IfaceBackendExts 'ModIfaceFinal
mi_final_exts = IfaceBackendExts 'ModIfaceFinal
ModIfaceBackend
final_iface_exts }
   --
   ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
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)

-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
-- (in particular, the orphan modules which are transitively imported by the
-- current module).
--
-- Q: Why do we need the hash at all, doesn't the list of transitively
-- imported orphan modules suffice?
--
-- A: If one of our transitive imports adds a new orphan instance, our
-- export hash must change so that modules which import us rebuild.  If we just
-- hashed the [Module], the hash would not change even when a new instance was
-- added to a module that already had an orphan instance.
--
-- Q: Why don't we just hash the orphan hashes of our direct dependencies?
-- Why the full transitive closure?
--
-- A: Suppose we have these modules:
--
--      module A where
--          instance Show (a -> b) where
--      module B where
--          import A -- **
--      module C where
--          import A
--          import B
--
-- Whether or not we add or remove the import to A in B affects the
-- orphan hash of B.  But it shouldn't really affect the orphan hash
-- of C.  If we hashed only direct dependencies, there would be no
-- way to tell that the net effect was a wash, and we'd be forced
-- to recompile C and everything else.
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes HscEnv
hsc_env [Module]
mods = do
  ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
  let
    hpt :: HomePackageTable
hpt        = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    pit :: PackageIfaceTable
pit        = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps
    get_orph_hash :: Module -> IO Fingerprint
get_orph_hash Module
mod =
          case HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
hpt PackageIfaceTable
pit Module
mod of
            Just ModIface
iface -> Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIfaceBackend -> Fingerprint
mi_orphan_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
            Maybe ModIface
Nothing    -> do -- similar to 'mkHashFun'
                ModIface
iface <- HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface
forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException
                            (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall lcl.
SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface (String -> SDoc
text String
"getOrphanHashes") Module
mod WhereFrom
ImportBySystem
                Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIfaceBackend -> Fingerprint
mi_orphan_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))

  --
  (Module -> IO Fingerprint) -> [Module] -> IO [Fingerprint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Module -> IO Fingerprint
get_orph_hash [Module]
mods


sortDependencies :: Dependencies -> Dependencies
sortDependencies :: Dependencies -> Dependencies
sortDependencies Dependencies
d
 = Deps { dep_mods :: [ModuleNameWithIsBoot]
dep_mods   = (ModuleNameWithIsBoot -> ModuleNameWithIsBoot -> Ordering)
-> [ModuleNameWithIsBoot] -> [ModuleNameWithIsBoot]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (FastString -> FastString -> Ordering
lexicalCompareFS (FastString -> FastString -> Ordering)
-> (ModuleNameWithIsBoot -> FastString)
-> ModuleNameWithIsBoot
-> ModuleNameWithIsBoot
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ModuleName -> FastString
moduleNameFS (ModuleName -> FastString)
-> (ModuleNameWithIsBoot -> ModuleName)
-> ModuleNameWithIsBoot
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod)) (Dependencies -> [ModuleNameWithIsBoot]
dep_mods Dependencies
d),
          dep_pkgs :: [(UnitId, Bool)]
dep_pkgs   = ((UnitId, Bool) -> (UnitId, Bool) -> Ordering)
-> [(UnitId, Bool)] -> [(UnitId, Bool)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (UnitId -> UnitId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (UnitId -> UnitId -> Ordering)
-> ((UnitId, Bool) -> UnitId)
-> (UnitId, Bool)
-> (UnitId, Bool)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (UnitId, Bool) -> UnitId
forall a b. (a, b) -> a
fst) (Dependencies -> [(UnitId, Bool)]
dep_pkgs Dependencies
d),
          dep_orphs :: [Module]
dep_orphs  = (Module -> Module -> Ordering) -> [Module] -> [Module]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Module -> Module -> Ordering
stableModuleCmp (Dependencies -> [Module]
dep_orphs Dependencies
d),
          dep_finsts :: [Module]
dep_finsts = (Module -> Module -> Ordering) -> [Module] -> [Module]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Module -> Module -> Ordering
stableModuleCmp (Dependencies -> [Module]
dep_finsts Dependencies
d),
          dep_plgins :: [ModuleName]
dep_plgins = (ModuleName -> ModuleName -> Ordering)
-> [ModuleName] -> [ModuleName]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (FastString -> FastString -> Ordering
lexicalCompareFS (FastString -> FastString -> Ordering)
-> (ModuleName -> FastString)
-> ModuleName
-> ModuleName
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ModuleName -> FastString
moduleNameFS) (Dependencies -> [ModuleName]
dep_plgins Dependencies
d) }

{-
************************************************************************
*                                                                      *
          The ABI of an IfaceDecl
*                                                                      *
************************************************************************

Note [The ABI of an IfaceDecl]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ABI of a declaration consists of:

   (a) the full name of the identifier (inc. module and package,
       because these are used to construct the symbol name by which
       the identifier is known externally).

   (b) the declaration itself, as exposed to clients.  That is, the
       definition of an Id is included in the fingerprint only if
       it is made available as an unfolding in the interface.

   (c) the fixity of the identifier (if it exists)
   (d) for Ids: rules
   (e) for classes: instances, fixity & rules for methods
   (f) for datatypes: instances, fixity & rules for constrs

Items (c)-(f) are not stored in the IfaceDecl, but instead appear
elsewhere in the interface file.  But they are *fingerprinted* with
the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
and fingerprinting that as part of the declaration.
-}

type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)

data IfaceDeclExtras
  = IfaceIdExtras IfaceIdExtras

  | IfaceDataExtras
       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)
       [IfaceInstABI]           -- Local class and family instances of this tycon
                                -- See Note [Orphans] in GHC.Core.InstEnv
       [AnnPayload]             -- Annotations of the type itself
       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations

  | IfaceClassExtras
       (Maybe Fixity)           -- Fixity of the class itself (if it exists)
       [IfaceInstABI]           -- Local instances of this class *or*
                                --   of its associated data types
                                -- See Note [Orphans] in GHC.Core.InstEnv
       [AnnPayload]             -- Annotations of the type itself
       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
       [IfExtName]              -- Default methods. If a module
                                -- mentions a class, then it can
                                -- instantiate the class and thereby
                                -- use the default methods, so we must
                                -- include these in the fingerprint of
                                -- a class.

  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]

  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]

  | IfaceOtherDeclExtras

data IfaceIdExtras
  = IdExtras
       (Maybe Fixity)           -- Fixity of the Id (if it exists)
       [IfaceRule]              -- Rules for the Id
       [AnnPayload]             -- Annotations for the Id

-- When hashing a class or family instance, we hash only the
-- DFunId or CoAxiom, because that depends on all the
-- information about the instance.
--
type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance

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
freeNamesDeclExtras :: IfaceDeclExtras -> UniqSet Name
freeNamesDeclExtras (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
freeNamesIdExtras :: IfaceIdExtras -> UniqSet Name
freeNamesIdExtras (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
Outputable.empty
  ppr (IfaceIdExtras  IfaceIdExtras
extras)    = IfaceIdExtras -> SDoc
ppr_id_extras IfaceIdExtras
extras
  ppr (IfaceSynonymExtras Maybe Fixity
fix [AnnPayload]
anns) = [SDoc] -> SDoc
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
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
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
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
text String
"<insts>"

ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s [IfaceIdExtras]
stuff = [SDoc] -> SDoc
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
ppr_id_extras :: IfaceIdExtras -> SDoc
ppr_id_extras (IdExtras Maybe Fixity
fix [IfaceRule]
rules [AnnPayload]
anns) = Maybe Fixity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Fixity
fix SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
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
$$ [SDoc] -> SDoc
vcat ((AnnPayload -> SDoc) -> [AnnPayload] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map AnnPayload -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AnnPayload]
anns)

-- This instance is used only to compute fingerprints
instance Binary IfaceDeclExtras where
  get :: BinHandle -> IO IfaceDeclExtras
get BinHandle
_bh = String -> IO IfaceDeclExtras
forall a. String -> a
panic String
"no get for IfaceDeclExtras"
  put_ :: BinHandle -> IfaceDeclExtras -> IO ()
put_ BinHandle
bh (IfaceIdExtras IfaceIdExtras
extras) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1; BinHandle -> IfaceIdExtras -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh IfaceIdExtras
extras
  put_ BinHandle
bh (IfaceDataExtras Maybe Fixity
fix [Name]
insts [AnnPayload]
anns [IfaceIdExtras]
cons) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2; BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
insts; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns; BinHandle -> [IfaceIdExtras] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceIdExtras]
cons
  put_ BinHandle
bh (IfaceClassExtras Maybe Fixity
fix [Name]
insts [AnnPayload]
anns [IfaceIdExtras]
methods [Name]
defms) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3
   BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix
   BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
insts
   BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns
   BinHandle -> [IfaceIdExtras] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceIdExtras]
methods
   BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
defms
  put_ BinHandle
bh (IfaceSynonymExtras Maybe Fixity
fix [AnnPayload]
anns) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
4; BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns
  put_ BinHandle
bh (IfaceFamilyExtras Maybe Fixity
fix [Name]
finsts [AnnPayload]
anns) = do
   BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
5; BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [Name] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Name]
finsts; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns
  put_ BinHandle
bh IfaceDeclExtras
IfaceOtherDeclExtras = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
6

instance Binary IfaceIdExtras where
  get :: BinHandle -> IO IfaceIdExtras
get BinHandle
_bh = String -> IO IfaceIdExtras
forall a. String -> a
panic String
"no get for IfaceIdExtras"
  put_ :: BinHandle -> IfaceIdExtras -> IO ()
put_ BinHandle
bh (IdExtras Maybe Fixity
fix [IfaceRule]
rules [AnnPayload]
anns)= do { BinHandle -> Maybe Fixity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Maybe Fixity
fix; BinHandle -> [IfaceRule] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [IfaceRule]
rules; BinHandle -> [AnnPayload] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [AnnPayload]
anns }

declExtras :: (OccName -> Maybe Fixity)
           -> (OccName -> [AnnPayload])
           -> OccEnv [IfaceRule]
           -> OccEnv [IfaceClsInst]
           -> OccEnv [IfaceFamInst]
           -> OccEnv IfExtName          -- lookup default method names
           -> IfaceDecl
           -> IfaceDeclExtras

declExtras :: (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]
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)
                           -- Include instances of the associated types
                           -- as well as instances of the class (#5147)
            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]
            -- Names of all the default methods (see Note [default method Name])
            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)


{- Note [default method Name] (see also #15970)

The Names for the default methods aren't available in Iface syntax.

* We originally start with a DefMethInfo from the class, contain a
  Name for the default method

* We turn that into Iface syntax as a DefMethSpec which lacks a Name
  entirely. Why? Because the Name can be derived from the method name
  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface
  file.

But now we have to get the Name back, because the class declaration's
fingerprint needs to depend on it (this was the bug in #15970).  This
is done in a slightly convoluted way:

* Then, in addFingerprints we build a map that maps OccNames to Names

* We pass that map to declExtras which laboriously looks up in the map
  (using the derived occurrence name) to recover the Name we have just
  thrown away.
-}

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` []

{-
-- for testing: use the md5sum command to generate fingerprints and
-- compare the results against our built-in version.
  fp' <- oldMD5 dflags bh
  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
               else return fp

oldMD5 dflags bh = do
  tmp <- newTempName dflags CurrentModule "bin"
  writeBinMem bh tmp
  tmp2 <- newTempName dflags CurrentModule "md5"
  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
  r <- system cmd
  case r of
    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
    ExitSuccess -> do
        hash_str <- readFile tmp2
        return $! readHexFingerprint hash_str
-}

----------------------
-- mkOrphMap partitions instance decls or rules into
--      (a) an OccEnv for ones that are not orphans,
--          mapping the local OccName to a list of its decls
--      (b) a list of orphan decls
mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
          -> [decl]             -- Sorted into canonical order
          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;
                                --      each sublist in canonical order
              [decl])           -- Orphan decls; in canonical order
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 (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)
        | Bool
otherwise = (OccEnv [decl]
non_orphs, decl
ddecl -> [decl] -> [decl]
forall a. a -> [a] -> [a]
:[decl]
orphs)

-- -----------------------------------------------------------------------------
-- Look up parents and versions of Names

-- This is like a global version of the mi_hash_fn field in each ModIface.
-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
-- the parent and version info.

mkHashFun
        :: HscEnv                       -- needed to look up versions
        -> ExternalPackageState         -- ditto
        -> (Name -> IO Fingerprint)
mkHashFun :: HscEnv -> ExternalPackageState -> Name -> IO Fingerprint
mkHashFun HscEnv
hsc_env ExternalPackageState
eps Name
name
  | Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
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))
  | Bool
otherwise
  = Module -> IO Fingerprint
lookup Module
orig_mod
  where
      home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
      pit :: PackageIfaceTable
pit = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps
      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
        MASSERT2( isExternalName name, ppr name )
        ModIface
iface <- case HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
hpt PackageIfaceTable
pit Module
mod of
                  Just ModIface
iface -> ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface
                  Maybe ModIface
Nothing ->
                      -- This can occur when we're writing out ifaces for
                      -- requirements; we didn't do any /real/ typechecking
                      -- so there's no guarantee everything is loaded.
                      -- Kind of a heinous hack.
                      HscEnv -> IfG ModIface -> IO ModIface
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG ModIface -> IO ModIface)
-> (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
-> IO ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IfG ModIface
forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException
                          (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface) -> IO ModIface
forall a b. (a -> b) -> a -> b
$ TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall gbl lcl a. TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow
                            -- For some unknown reason, we need to reset the
                            -- dynamicNow bit, otherwise only dynamic
                            -- interfaces are looked up and some tests fail
                            -- (e.g. T16219).
                          (TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
 -> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface))
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall a b. (a -> b) -> a -> b
$ SDoc
-> Module
-> WhereFrom
-> TcRnIf IfGblEnv () (MaybeErr SDoc ModIface)
forall lcl.
SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)
loadInterface (String -> SDoc
text String
"lookupVers2") Module
mod WhereFrom
ImportBySystem
        Fingerprint -> IO Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ (OccName, Fingerprint) -> Fingerprint
forall a b. (a, b) -> b
snd (ModIfaceBackend -> OccName -> Maybe (OccName, Fingerprint)
mi_hash_fn (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface) OccName
occ 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
"lookupVers1" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ))


-- | Creates cached lookup for the 'mi_anns' field of ModIface
-- Hackily, we use "module" as the OccName for any module-level annotations
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
_   -> String -> OccName
mkVarOcc String
"module"
      , [AnnPayload
value])
    -- flipping (++), so the first argument is always short
    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)