| ... |
... |
@@ -54,7 +54,6 @@ import GHC.Runtime.Context |
|
54
|
54
|
import Language.Haskell.Syntax.ImpExp
|
|
55
|
55
|
import GHC.Types.UnresolvedImport
|
|
56
|
56
|
|
|
57
|
|
-import GHC.Data.Graph.Directed
|
|
58
|
57
|
import GHC.Data.FastString
|
|
59
|
58
|
import GHC.Data.Maybe ( expectJust )
|
|
60
|
59
|
import qualified GHC.Data.Maybe as M
|
| ... |
... |
@@ -77,7 +76,7 @@ import GHC.Types.Target |
|
77
|
76
|
import GHC.Types.SourceFile
|
|
78
|
77
|
import GHC.Types.SourceError
|
|
79
|
78
|
import GHC.Types.SrcLoc
|
|
80
|
|
-import GHC.Types.Unique.Map
|
|
|
79
|
+import GHC.Types.Unique.Set
|
|
81
|
80
|
import GHC.Types.PkgQual
|
|
82
|
81
|
import GHC.Types.Basic
|
|
83
|
82
|
|
| ... |
... |
@@ -91,6 +90,7 @@ import GHC.Unit.Module.Graph |
|
91
|
90
|
import GHC.Unit.Module.Deps
|
|
92
|
91
|
import qualified GHC.Unit.Home.Graph as HUG
|
|
93
|
92
|
import GHC.Unit.Module.Stage
|
|
|
93
|
+import GHC.Unit.External.Index
|
|
94
|
94
|
|
|
95
|
95
|
import Data.Either ( partitionEithers, lefts )
|
|
96
|
96
|
import qualified Data.Map as Map
|
| ... |
... |
@@ -260,11 +260,9 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo |
|
260
|
260
|
imps_cache <- newIORef Map.empty
|
|
261
|
261
|
(root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg
|
|
262
|
262
|
(getRootSummary excl_mods summ_cache imps_cache)
|
|
263
|
|
- let closure_errs = checkHomeUnitsClosed unit_env
|
|
264
|
|
- unit_env = hsc_unit_env hsc_env
|
|
265
|
|
-
|
|
266
|
|
- all_errs = closure_errs ++ root_errs
|
|
267
|
|
-
|
|
|
263
|
+ let unit_env = hsc_unit_env hsc_env
|
|
|
264
|
+ closure_errs <- checkHomeUnitsClosed unit_env
|
|
|
265
|
+ let all_errs = closure_errs ++ root_errs
|
|
268
|
266
|
case all_errs of
|
|
269
|
267
|
[] -> do
|
|
270
|
268
|
(downsweep_errs, downsweep_nodes) <-
|
| ... |
... |
@@ -933,52 +931,66 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do |
|
933
|
931
|
-- * Check/validate properties and error out
|
|
934
|
932
|
--------------------------------------------------------------------------------
|
|
935
|
933
|
|
|
936
|
|
--- | This function checks then important property that if both p and q are home units
|
|
937
|
|
--- then any dependency of p, which transitively depends on q is also a home unit.
|
|
938
|
|
---
|
|
939
|
|
--- See Note [Multiple Home Units], section 'Closure Property'.
|
|
940
|
|
-checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
|
|
941
|
|
-checkHomeUnitsClosed ue
|
|
942
|
|
- | Set.null bad_unit_ids = []
|
|
943
|
|
- | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
|
|
|
934
|
+-- | Checks whether the given unit environment has the closure property. See
|
|
|
935
|
+-- the section “Closure Property” in @Note [Multiple Home Units]@.
|
|
|
936
|
+checkHomeUnitsClosed :: UnitEnv -> IO [DriverMessages]
|
|
|
937
|
+checkHomeUnitsClosed unit_env = do
|
|
|
938
|
+ unit_infos <- globalUnits <$> readIORef (uic_index (ue_uic unit_env))
|
|
|
939
|
+ return $ case offending_dependencies unit_infos of
|
|
|
940
|
+ [] -> []
|
|
|
941
|
+ offenders -> [
|
|
|
942
|
+ singleMessage $
|
|
|
943
|
+ mkPlainErrorMsgEnvelope error_source_span $
|
|
|
944
|
+ DriverHomePackagesNotClosed offenders
|
|
|
945
|
+ ]
|
|
944
|
946
|
where
|
|
945
|
|
- home_id_set = HUG.allUnits $ ue_home_unit_graph ue
|
|
946
|
|
- bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
|
|
947
|
|
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
|
|
948
|
947
|
|
|
949
|
|
- downwards_closure :: Graph (Node UnitId UnitId)
|
|
950
|
|
- downwards_closure = graphFromEdgedVerticesUniq graphNodes
|
|
|
948
|
+ home_unit_data :: [(UnitId, HomeUnitEnv)]
|
|
|
949
|
+ home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env)
|
|
951
|
950
|
|
|
952
|
|
- inverse_closure = graphReachability $ transposeG downwards_closure
|
|
|
951
|
+ home_units :: UniqSet UnitId
|
|
|
952
|
+ home_units = mkUniqSet (map fst home_unit_data)
|
|
953
|
953
|
|
|
954
|
|
- upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
|
|
|
954
|
+ referenced_external_units :: [UnitId]
|
|
|
955
|
+ referenced_external_units
|
|
|
956
|
+ = concatMap (map (toUnitId . fst) . explicitUnits . homeUnitEnv_units . snd)
|
|
|
957
|
+ home_unit_data
|
|
955
|
958
|
|
|
956
|
|
- all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
|
|
957
|
|
- all_unit_direct_deps
|
|
958
|
|
- = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
|
|
959
|
|
- where
|
|
960
|
|
- go rest this this_uis =
|
|
961
|
|
- plusUniqMap_C Set.union
|
|
962
|
|
- (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
|
|
963
|
|
- rest
|
|
964
|
|
- where
|
|
965
|
|
- external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
|
|
966
|
|
- this_units = homeUnitEnv_units this_uis
|
|
967
|
|
- this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
|
|
968
|
|
-
|
|
969
|
|
- graphNodes :: [Node UnitId UnitId]
|
|
970
|
|
- graphNodes = go Set.empty home_id_set
|
|
971
|
|
- where
|
|
972
|
|
- go done todo
|
|
973
|
|
- = case Set.minView todo of
|
|
974
|
|
- Nothing -> []
|
|
975
|
|
- Just (uid, todo')
|
|
976
|
|
- | Set.member uid done -> go done todo'
|
|
977
|
|
- | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
|
|
978
|
|
- Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
|
|
979
|
|
- Just depends ->
|
|
980
|
|
- let todo'' = (depends Set.\\ done) `Set.union` todo'
|
|
981
|
|
- in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
|
|
|
959
|
+ offending_dependencies :: GlobalUnitInfoMap -> [(UnitId, UnitId)]
|
|
|
960
|
+ offending_dependencies unit_infos
|
|
|
961
|
+ = collect emptyUniqSet referenced_external_units
|
|
|
962
|
+ where
|
|
|
963
|
+
|
|
|
964
|
+ collect :: UniqSet UnitId -> [UnitId] -> [(UnitId, UnitId)]
|
|
|
965
|
+ collect _ [] = []
|
|
|
966
|
+ collect processed (current : remaining)
|
|
|
967
|
+ | current `elementOfUniqSet` processed
|
|
|
968
|
+ = collect processed remaining
|
|
|
969
|
+ | otherwise
|
|
|
970
|
+ = let
|
|
|
971
|
+
|
|
|
972
|
+ needed :: [UnitId]
|
|
|
973
|
+ needed | Just current_infos <- unitInfosOfUnitId current unit_infos
|
|
|
974
|
+ = concatMap unitDepends current_infos
|
|
|
975
|
+ | otherwise
|
|
|
976
|
+ = pprPanic "Unit not found during closure property check"
|
|
|
977
|
+ (ppr current)
|
|
|
978
|
+
|
|
|
979
|
+ current_offenders :: [(UnitId, UnitId)]
|
|
|
980
|
+ current_offenders
|
|
|
981
|
+ | current `elementOfUniqSet` home_units
|
|
|
982
|
+ = []
|
|
|
983
|
+ | otherwise
|
|
|
984
|
+ = map ((,) current) $
|
|
|
985
|
+ nonDetEltsUniqSet $
|
|
|
986
|
+ mkUniqSet needed `intersectUniqSets` home_units
|
|
|
987
|
+
|
|
|
988
|
+ in
|
|
|
989
|
+ current_offenders ++ collect (addOneToUniqSet processed current)
|
|
|
990
|
+ (needed ++ remaining)
|
|
|
991
|
+
|
|
|
992
|
+ error_source_span :: SrcSpan
|
|
|
993
|
+ error_source_span = mkGeneralSrcSpan (fsLit "<command line>")
|
|
982
|
994
|
|
|
983
|
995
|
--------------------------------------------------------------------------------
|
|
984
|
996
|
-- * Enable Code Gen for Template Haskell
|