| ... |
... |
@@ -6,6 +6,8 @@ |
|
6
|
6
|
{-# LANGUAGE BlockArguments #-}
|
|
7
|
7
|
{-# LANGUAGE ViewPatterns #-}
|
|
8
|
8
|
|
|
|
9
|
+{-# OPTIONS_GHC -Wno-invalid-haddock #-}
|
|
|
10
|
+
|
|
9
|
11
|
-- | See Note [The ModuleGraph]
|
|
10
|
12
|
module GHC.Driver.Downsweep
|
|
11
|
13
|
( downsweep
|
| ... |
... |
@@ -54,7 +56,6 @@ import GHC.Runtime.Context |
|
54
|
56
|
import Language.Haskell.Syntax.ImpExp
|
|
55
|
57
|
import GHC.Types.UnresolvedImport
|
|
56
|
58
|
|
|
57
|
|
-import GHC.Data.Graph.Directed
|
|
58
|
59
|
import GHC.Data.FastString
|
|
59
|
60
|
import GHC.Data.Maybe ( expectJust )
|
|
60
|
61
|
import qualified GHC.Data.Maybe as M
|
| ... |
... |
@@ -71,12 +72,14 @@ import GHC.Utils.Logger |
|
71
|
72
|
import GHC.Utils.Fingerprint
|
|
72
|
73
|
import GHC.Utils.TmpFs
|
|
73
|
74
|
import GHC.Utils.Constants
|
|
|
75
|
+import GHC.Utils.Monad.State.Strict
|
|
74
|
76
|
|
|
75
|
77
|
import GHC.Types.Error
|
|
76
|
78
|
import GHC.Types.Target
|
|
77
|
79
|
import GHC.Types.SourceFile
|
|
78
|
80
|
import GHC.Types.SourceError
|
|
79
|
81
|
import GHC.Types.SrcLoc
|
|
|
82
|
+import GHC.Types.Unique.Set
|
|
80
|
83
|
import GHC.Types.Unique.Map
|
|
81
|
84
|
import GHC.Types.PkgQual
|
|
82
|
85
|
import GHC.Types.Basic
|
| ... |
... |
@@ -91,9 +94,12 @@ import GHC.Unit.Module.Graph |
|
91
|
94
|
import GHC.Unit.Module.Deps
|
|
92
|
95
|
import qualified GHC.Unit.Home.Graph as HUG
|
|
93
|
96
|
import GHC.Unit.Module.Stage
|
|
|
97
|
+import GHC.Unit.External.Index (GlobalUnitKey, mkGlobalUnitKey)
|
|
94
|
98
|
|
|
95
|
99
|
import Data.Either ( partitionEithers, lefts )
|
|
|
100
|
+import Data.Map (Map)
|
|
96
|
101
|
import qualified Data.Map as Map
|
|
|
102
|
+import Data.Set (Set)
|
|
97
|
103
|
import qualified Data.Set as Set
|
|
98
|
104
|
|
|
99
|
105
|
import Control.Concurrent.MVar
|
| ... |
... |
@@ -101,7 +107,7 @@ import Control.Monad |
|
101
|
107
|
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
|
|
102
|
108
|
import qualified Control.Monad.Catch as MC
|
|
103
|
109
|
import Data.Maybe
|
|
104
|
|
-import Data.List (partition)
|
|
|
110
|
+import Data.List (sort, partition)
|
|
105
|
111
|
import Data.Time
|
|
106
|
112
|
import Data.List (unfoldr)
|
|
107
|
113
|
import Data.Bifunctor (first, bimap)
|
| ... |
... |
@@ -933,52 +939,172 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do |
|
933
|
939
|
-- * Check/validate properties and error out
|
|
934
|
940
|
--------------------------------------------------------------------------------
|
|
935
|
941
|
|
|
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.
|
|
|
942
|
+-- | Checks whether the given 'UnitEnv' has the closure property.
|
|
938
|
943
|
--
|
|
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)]
|
|
|
944
|
+-- See the section “Closure Property” in @Note [Multiple Home Units]@ for the
|
|
|
945
|
+-- definition of the closure property an @Note [Home unit closure property
|
|
|
946
|
+-- check]@ below for a discussion of the algorithm used for this check, its
|
|
|
947
|
+-- justification, and a potential alternative.
|
|
|
948
|
+checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
|
|
|
949
|
+checkHomeUnitsClosed unit_env
|
|
|
950
|
+ | null offenders = []
|
|
|
951
|
+ | otherwise = [
|
|
|
952
|
+ singleMessage $
|
|
|
953
|
+ mkPlainErrorMsgEnvelope error_source_span $
|
|
|
954
|
+ DriverHomePackagesNotClosed (sort offenders)
|
|
|
955
|
+ ]
|
|
944
|
956
|
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
|
957
|
|
|
949
|
|
- downwards_closure :: Graph (Node UnitId UnitId)
|
|
950
|
|
- downwards_closure = graphFromEdgedVerticesUniq graphNodes
|
|
|
958
|
+ -- | The 'UnitId' and 'HomeUnitEnv' of each home unit.
|
|
|
959
|
+ home_unit_data :: [(UnitId, HomeUnitEnv)]
|
|
|
960
|
+ home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env)
|
|
|
961
|
+
|
|
|
962
|
+ -- | The 'UnitId's of all home units.
|
|
|
963
|
+ home_units :: UniqSet UnitId
|
|
|
964
|
+ home_units = mkUniqSet (map fst home_unit_data)
|
|
|
965
|
+
|
|
|
966
|
+ -- | All offending dependencies. A dependency of a unit /u/ on a unit /v/ is
|
|
|
967
|
+ -- offending exactly if /u/ is an external unit reachable from a home unit
|
|
|
968
|
+ -- and /v/ is a home unit. Each such dependency is represented in this list
|
|
|
969
|
+ -- by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/.
|
|
|
970
|
+ offenders :: [(UnitId, UnitId)]
|
|
|
971
|
+ offenders
|
|
|
972
|
+ = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) $
|
|
|
973
|
+ Set.empty
|
|
|
974
|
+ where
|
|
951
|
975
|
|
|
952
|
|
- inverse_closure = graphReachability $ transposeG downwards_closure
|
|
|
976
|
+ -- | Collects offending dependencies.
|
|
|
977
|
+ collect :: [UnitState]
|
|
|
978
|
+ -- ^ The 'UnitState's of the home units from which to traverse
|
|
|
979
|
+ -- the dependency graph.
|
|
|
980
|
+ -> State (Set GlobalUnitKey) [(UnitId, UnitId)]
|
|
|
981
|
+ -- ^ A stateful computation that collects offending dependencies
|
|
|
982
|
+ -- that have not yet been found, using its state to keep track
|
|
|
983
|
+ -- of which units have already been considered as sources of
|
|
|
984
|
+ -- offending dependencies.
|
|
|
985
|
+ collect []
|
|
|
986
|
+ = pure []
|
|
|
987
|
+ collect (current_unit_state : remaining_unit_states)
|
|
|
988
|
+ = (++) <$> collect_for_home_unit
|
|
|
989
|
+ (unitInfoMap current_unit_state)
|
|
|
990
|
+ (map (toUnitId . fst) $ explicitUnits $ current_unit_state)
|
|
|
991
|
+ <*> collect remaining_unit_states
|
|
|
992
|
+ where
|
|
953
|
993
|
|
|
954
|
|
- upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
|
|
|
994
|
+ -- | Collects offending dependencies that are reachable from a particular
|
|
|
995
|
+ -- home unit.
|
|
|
996
|
+ collect_for_home_unit
|
|
|
997
|
+ :: UnitInfoMap
|
|
|
998
|
+ -- ^ The 'UnitInfoMap' of the home unit.
|
|
|
999
|
+ -> [UnitId]
|
|
|
1000
|
+ -- ^ The 'UnitId's of the units from which to traverse the dependency
|
|
|
1001
|
+ -- graph.
|
|
|
1002
|
+ -> State (Set GlobalUnitKey) [(UnitId, UnitId)]
|
|
|
1003
|
+ -- ^ A stateful computation that collects offending dependencies that
|
|
|
1004
|
+ -- have not yet been found, using its state to keep track of which
|
|
|
1005
|
+ -- units have already been considered as sources of offending
|
|
|
1006
|
+ -- dependencies.
|
|
|
1007
|
+ collect_for_home_unit _ []
|
|
|
1008
|
+ = return []
|
|
|
1009
|
+ collect_for_home_unit unit_info_map (current_unit : remaining_units) = do
|
|
|
1010
|
+ let
|
|
|
1011
|
+
|
|
|
1012
|
+ -- | The 'UnitInfo' of the current unit.
|
|
|
1013
|
+ unit_info :: UnitInfo
|
|
|
1014
|
+ unit_info
|
|
|
1015
|
+ = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $
|
|
|
1016
|
+ lookupUniqMap unit_info_map current_unit
|
|
|
1017
|
+ where
|
|
|
1018
|
+
|
|
|
1019
|
+ -- | The message that says that a unit was not found.
|
|
|
1020
|
+ unit_not_found_msg :: String
|
|
|
1021
|
+ unit_not_found_msg = "Unit not found during closure property check"
|
|
|
1022
|
+
|
|
|
1023
|
+ -- | A 'GlobalUnitKey' that identifies the current unit.
|
|
|
1024
|
+ global_unit_key :: GlobalUnitKey
|
|
|
1025
|
+ global_unit_key = mkGlobalUnitKey current_unit (unitAbiHash unit_info)
|
|
|
1026
|
+
|
|
|
1027
|
+ has_been_processed <- gets (Set.member global_unit_key)
|
|
|
1028
|
+ if has_been_processed
|
|
|
1029
|
+ then collect_for_home_unit unit_info_map remaining_units
|
|
|
1030
|
+ else do
|
|
|
1031
|
+ modify (Set.insert global_unit_key)
|
|
|
1032
|
+ let
|
|
|
1033
|
+
|
|
|
1034
|
+ -- | The 'UnitId's of the units that the current unit depends on.
|
|
|
1035
|
+ needed_units :: [UnitId]
|
|
|
1036
|
+ needed_units = unitDepends unit_info
|
|
|
1037
|
+
|
|
|
1038
|
+ -- | The offending dependencies of the current unit.
|
|
|
1039
|
+ current_offenders :: [(UnitId, UnitId)]
|
|
|
1040
|
+ current_offenders
|
|
|
1041
|
+ | current_unit `elementOfUniqSet` home_units
|
|
|
1042
|
+ = []
|
|
|
1043
|
+ | otherwise
|
|
|
1044
|
+ = map ((,) current_unit) $
|
|
|
1045
|
+ nonDetEltsUniqSet $
|
|
|
1046
|
+ mkUniqSet needed_units `intersectUniqSets` home_units
|
|
|
1047
|
+
|
|
|
1048
|
+ remaining_offenders <- collect_for_home_unit unit_info_map $
|
|
|
1049
|
+ needed_units ++ remaining_units
|
|
|
1050
|
+ return $ current_offenders ++ remaining_offenders
|
|
|
1051
|
+
|
|
|
1052
|
+ -- | A fake source span used for reporting violations of the closure property.
|
|
|
1053
|
+ error_source_span :: SrcSpan
|
|
|
1054
|
+ error_source_span = mkGeneralSrcSpan (fsLit "<command line>")
|
|
955
|
1055
|
|
|
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''
|
|
|
1056
|
+{-
|
|
|
1057
|
+
|
|
|
1058
|
+Note [Home unit closure property check]
|
|
|
1059
|
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
1060
|
+
|
|
|
1061
|
+Per the definition in Note [Multiple Home Units], a unit environment has the
|
|
|
1062
|
+closure property exactly if there are no paths /h/₁ →* /e/ →* /h/₂ in the
|
|
|
1063
|
+dependency graph, where /h/₁ and /h/₂ are home units and /e/ is an external
|
|
|
1064
|
+unit. However, the algorithm used by 'checkHomeUnitsClosed' searches for
|
|
|
1065
|
+so-called offending dependencies, which are dependencies /e/ → /h/₂ that are
|
|
|
1066
|
+part of a path /h/₁ →* /e/ → /h/₂ in the dependency graph. To see that this is a
|
|
|
1067
|
+viable approach, consider the following:
|
|
|
1068
|
+
|
|
|
1069
|
+ * A path /h/₁ →* /e/ → /h/₂ is also a path /h/₁ →* /e/ →* /h/₂.
|
|
|
1070
|
+
|
|
|
1071
|
+ * For each path /h/₁ →* /e/ →* /h/₂, there exists a path /h/₁ →* /e/′ → /h/₂′,
|
|
|
1072
|
+ where /e/′ is an external unit and /h/₂′ is a home unit. Such a path can be
|
|
|
1073
|
+ constructed by taking as /h/₂′ the first home unit on the path /e/ →* /h/₂
|
|
|
1074
|
+ and as /e/′ the, necessarily external, unit preceding it.
|
|
|
1075
|
+
|
|
|
1076
|
+Concretely, the algorithm picks one home unit after the other, determines what
|
|
|
1077
|
+units it directly depends on, and, starting from them, follows unit dependencies
|
|
|
1078
|
+to search for offending dependencies. It does not follow dependencies that have
|
|
|
1079
|
+been followed before, possibly when processing another home unit. To achieve
|
|
|
1080
|
+this, the algorithm tracks, across home units, from which units it has already
|
|
|
1081
|
+followed dependencies. For this tracking, it identifies each unit by a
|
|
|
1082
|
+'GlobalUnitKey', which is a pair of a 'UnitId' and an ABI hash. Using only a
|
|
|
1083
|
+'UnitId' would not work, because 'UnitId's are not always globally unique. Also
|
|
|
1084
|
+using only an ABI hash is not an option, because an ABI hash is not necessarily
|
|
|
1085
|
+an ABI hash: it can also be the string @"inline"@.
|
|
|
1086
|
+
|
|
|
1087
|
+The correctness of this algorithm rests on the, likely correct, assumption that,
|
|
|
1088
|
+among the units mentioned in the 'UnitState' of a particular home unit, any unit
|
|
|
1089
|
+can be uniquely identified by its 'UnitId' and thus 'UnitId' clashes can only
|
|
|
1090
|
+occur across the 'UnitState's of different home units.
|
|
|
1091
|
+
|
|
|
1092
|
+An alternative approach to finding offending dependencies would be to follow
|
|
|
1093
|
+dependencies starting from all units that /any/ home unit directly depends on
|
|
|
1094
|
+instead of considering the different home units separately. A corresponding
|
|
|
1095
|
+algorithm could in principle find the dependencies of a particular unit
|
|
|
1096
|
+independently of any home unit by fetching the 'UnitInfo' of that unit from the
|
|
|
1097
|
+'GlobalUnitInfoMap'. However, for such a lookup the algorithm would need not
|
|
|
1098
|
+only the 'UnitId' but also the ABI hash of the unit in question. Therefore,
|
|
|
1099
|
+whenever following a dependency of a unit /u/ on a unit /v/, it would have to
|
|
|
1100
|
+determine the ABI hash of /v/, so that it could later look up /v/’s
|
|
|
1101
|
+dependencies. The ABI hashes of all units that /u/ depends on should be
|
|
|
1102
|
+available in the 'unitAbiDepends' field of /u/’s 'UnitInfo'. However, at the
|
|
|
1103
|
+time of writing, 'unitAbiDepends' never contained anything other than the empty
|
|
|
1104
|
+list during GHC test runs, which indicated that this alternative solution was
|
|
|
1105
|
+impossible to realize.
|
|
|
1106
|
+
|
|
|
1107
|
+-}
|
|
982
|
1108
|
|
|
983
|
1109
|
--------------------------------------------------------------------------------
|
|
984
|
1110
|
-- * Enable Code Gen for Template Haskell
|
| ... |
... |
@@ -1763,7 +1889,7 @@ data NodeRes v |
|
1763
|
1889
|
--
|
|
1764
|
1890
|
-- See also Note [Downsweep Control Flow and Caching]
|
|
1765
|
1891
|
dfsBuild :: (Ord k, Monad m)
|
|
1766
|
|
- => Maybe (Map.Map k (NodeRes v))
|
|
|
1892
|
+ => Maybe (Map k (NodeRes v))
|
|
1767
|
1893
|
-- ^ Base map, existing results. We won't re-expand any of the nodes
|
|
1768
|
1894
|
-- already present in this map.
|
|
1769
|
1895
|
-> [n]
|
| ... |
... |
@@ -1773,7 +1899,7 @@ dfsBuild :: (Ord k, Monad m) |
|
1773
|
1899
|
-> (n -> m (NodeRes (v,[n])))
|
|
1774
|
1900
|
-- ^ Expand this node into its payload result and into the list of
|
|
1775
|
1901
|
-- children nodes to visit next.
|
|
1776
|
|
- -> m (Map.Map k (NodeRes v))
|
|
|
1902
|
+ -> m (Map k (NodeRes v))
|
|
1777
|
1903
|
-- ^ The result accumulates the payload of expanding the root nodes
|
|
1778
|
1904
|
-- and all nodes transitively reachable from those roots.
|
|
1779
|
1905
|
dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
|