summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface/Recomp.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Iface/Recomp.hs')
-rw-r--r--compiler/GHC/Iface/Recomp.hs62
1 files changed, 36 insertions, 26 deletions
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 6b184787fa..fc12701b61 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -53,8 +53,6 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
-
-import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.State
@@ -78,6 +76,7 @@ import qualified Data.Semigroup
import GHC.List (uncons)
import Data.Ord
import Data.Containers.ListUtils
+import Data.Bifunctor
{-
-----------------------------------------------
@@ -121,6 +120,11 @@ data RecompileRequired
-- to force recompilation; the String says what (one-line summary)
deriving (Eq)
+instance Outputable RecompileRequired where
+ ppr UpToDate = text "UpToDate"
+ ppr MustCompile = text "MustCompile"
+ ppr (RecompBecause r) = text "RecompBecause" <+> ppr r
+
instance Semigroup RecompileRequired where
UpToDate <> r = r
mc <> _ = mc
@@ -141,8 +145,8 @@ data RecompReason
| HieOutdated
| SigsMergeChanged
| ModuleChanged ModuleName
- | ModuleRemoved ModuleName
- | ModuleAdded ModuleName
+ | ModuleRemoved (UnitId, ModuleName)
+ | ModuleAdded (UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
@@ -155,6 +159,8 @@ data RecompReason
| MissingDynObjectFile
| MissingDynHiFile
| MismatchedDynHiFile
+ | ObjectsChanged
+ | LibraryChanged
deriving (Eq)
instance Outputable RecompReason where
@@ -173,8 +179,8 @@ instance Outputable RecompReason where
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
ModuleChangedIface m -> ppr m <+> text "changed (interface)"
- ModuleRemoved m -> ppr m <+> text "removed"
- ModuleAdded m -> ppr m <+> text "added"
+ ModuleRemoved (_uid, m) -> ppr m <+> text "removed"
+ ModuleAdded (_uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
@@ -185,6 +191,8 @@ instance Outputable RecompReason where
MissingDynObjectFile -> text "Missing dynamic object file"
MissingDynHiFile -> text "Missing dynamic interface file"
MismatchedDynHiFile -> text "Mismatched dynamic interface file"
+ ObjectsChanged -> text "Objects changed"
+ LibraryChanged -> text "Library changed"
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
@@ -526,7 +534,7 @@ checkMergedSignatures hsc_env mod_summary iface = do
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
- res_normal <- classify_import (findImportedModule fc fopts units mhome_unit) (ms_textual_imps summary ++ ms_srcimps summary)
+ res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return recomp
@@ -539,6 +547,11 @@ checkDependencies hsc_env summary iface
return (res1 `mappend` res2)
where
+ classify_import :: (ModuleName -> t -> IO FindResult)
+ -> [(t, GenLocated l ModuleName)]
+ -> IfG
+ [Either
+ RecompileRequired (Either (UnitId, ModuleName) (String, UnitId))]
classify_import find_import imports =
liftIO $ traverse (\(mb_pkg, L _ mod) ->
let reason = ModuleChanged mod
@@ -548,9 +561,10 @@ checkDependencies hsc_env summary iface
fopts = initFinderOpts dflags
logger = hsc_logger hsc_env
fc = hsc_FC hsc_env
- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
+ mhome_unit = hsc_home_unit_maybe hsc_env
+ all_home_units = hsc_all_home_unit_ids hsc_env
units = hsc_units hsc_env
- prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface)
+ prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)
prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))
(dep_plugin_pkgs (mi_deps iface)))
bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface)))
@@ -560,23 +574,26 @@ checkDependencies hsc_env summary iface
-- GHC.Prim is very special and doesn't appear in ms_textual_imps but
-- ghc-prim will appear in the package dependencies still. In order to not confuse
-- the recompilation logic we need to not forget we imported GHC.Prim.
- fake_ghc_prim_import = if notHomeUnitId mhome_unit primUnitId
- then Right ("GHC.Prim", primUnitId)
- else Left (mkModuleName "GHC.Prim")
+ fake_ghc_prim_import = case mhome_unit of
+ Just home_unit
+ | homeUnitId home_unit == primUnitId
+ -> Left (primUnitId, mkModuleName "GHC.Prim")
+ _ -> Right ("GHC.Prim", primUnitId)
classify _ (Found _ mod)
- | Just home_unit <- mhome_unit
- , isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod))
+ | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))
| otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod))
classify reason _ = Left (RecompBecause reason)
+ check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods [] [] = return UpToDate
check_mods [] (old:_) = do
-- This case can happen when a module is change from HPT to package import
trace_hi_diffs logger $
- text "module no longer " <> quotes (ppr old) <>
+ text "module no longer" <+> quotes (ppr old) <+>
text "in dependencies"
+
return (RecompBecause (ModuleRemoved old))
check_mods (new:news) olds
| Just (old, olds') <- uncons olds
@@ -1255,21 +1272,14 @@ addFingerprints hsc_env iface0
-- to recompile C and everything else.
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
- eps <- hscEPS hsc_env
let
- hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
- pit = eps_PIT eps
ctx = initSDocContext dflags defaultUserStyle
- get_orph_hash mod =
- case lookupIfaceByModule hpt pit mod of
- Just iface -> return (mi_orphan_hash (mi_final_exts iface))
- Nothing -> do -- similar to 'mkHashFun'
- iface <- initIfaceLoad hsc_env . withException ctx
+ get_orph_hash mod = do
+ iface <- initIfaceLoad hsc_env . withException ctx
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
- return (mi_orphan_hash (mi_final_exts iface))
+ return (mi_orphan_hash (mi_final_exts iface))
- --
mapM get_orph_hash mods
@@ -1546,7 +1556,7 @@ mkHashFun hsc_env eps name
where
home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
- hpt = hsc_HPT hsc_env
+ hpt = hsc_HUG hsc_env
pit = eps_PIT eps
ctx = initSDocContext dflags defaultUserStyle
occ = nameOccName name
View Lorry Controller Status