[Git][ghc/ghc][wip/js-th] 2 commits: Revert "More refactoring"
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Mon Jan 23 13:46:42 UTC 2023
Sylvain Henry pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC
Commits:
7580dcec by Sylvain Henry at 2023-01-23T14:50:52+01:00
Revert "More refactoring"
This reverts commit 1942705b24f7c956a2dc15028daed41e24c9d31d.
- - - - -
3b85f87f by Sylvain Henry at 2023-01-23T14:51:00+01:00
Revert "Refactor hptModulesBelow"
This reverts commit 9840d044dec76cd3a6fb34af0bb6121d7ce933b8.
- - - - -
2 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Unit/Module/Graph.hs
Changes:
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -84,7 +84,10 @@ import GHC.Utils.Logger
import Data.IORef
import qualified Data.Set as Set
+import Data.Set (Set)
import GHC.Unit.Module.Graph
+import Data.List (sort)
+import qualified Data.Map as Map
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
@@ -264,6 +267,35 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)
(hugElts (hsc_HUG hsc_env))
+-- | This function returns all the modules belonging to the home-unit that can
+-- be reached by following the given dependencies. Additionally, if both the
+-- boot module and the non-boot module can be reached, it only returns the
+-- non-boot one.
+hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
+hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
+ where
+ td_map = mgTransDeps (hsc_mod_graph hsc_env)
+
+ modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
+
+ filtered_mods = Set.fromDistinctAscList . filter_mods . sort
+
+ -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
+ -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
+ -- linear sweep with a window of size 2 to remove boot modules for which we
+ -- have the corresponding non-boot.
+ filter_mods = \case
+ (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
+ | m1 == m2 && uid1 == uid2 ->
+ let !r' = case b1 of
+ NotBoot -> r1
+ IsBoot -> r2
+ in r' : filter_mods rs
+ | otherwise -> r1 : filter_mods (r2:rs)
+ rs -> rs
+
+
+
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
@@ -272,12 +304,11 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
| otherwise
= let hug = hsc_HUG hsc_env
- mg = hsc_mod_graph hsc_env
in
[ thing
|
-- Find each non-hi-boot module below me
- (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn)
+ (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)
, include_hi_boot || (is_boot == NotBoot)
-- unsavoury: when compiling the base package with --make, we
@@ -293,7 +324,7 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "When starting from" <+> ppr mn,
- text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),
+ text "below:" <+> ppr (hptModulesBelow hsc_env uid mn),
text "Probable cause: out-of-date interface files"]
-- This really shouldn't happen, but see #962
, thing <- things
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -22,7 +22,6 @@ module GHC.Unit.Module.Graph
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
- , moduleGraphModulesBelow
, moduleGraphNodes
, SummaryNode
@@ -63,14 +62,12 @@ import System.FilePath
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
import qualified Data.Set as Set
-import Data.Set (Set)
import GHC.Unit.Module
import GHC.Linker.Static.Utils
import Data.Bifunctor
import Data.Either
import Data.Function
-import Data.List (sort)
import GHC.Data.List.SetOps
-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
@@ -388,30 +385,3 @@ msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)
type ModNodeKey = ModuleNameWithIsBoot
-
--- | This function returns all the modules belonging to the home-unit that can
--- be reached by following the given dependencies. Additionally, if both the
--- boot module and the non-boot module can be reached, it only returns the
--- non-boot one.
-moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
-moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
- where
- td_map = mgTransDeps mg
-
- modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
-
- filtered_mods = Set.fromDistinctAscList . filter_mods . sort
-
- -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
- -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
- -- linear sweep with a window of size 2 to remove boot modules for which we
- -- have the corresponding non-boot.
- filter_mods = \case
- (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
- | m1 == m2 && uid1 == uid2 ->
- let !r' = case b1 of
- NotBoot -> r1
- IsBoot -> r2
- in r' : filter_mods rs
- | otherwise -> r1 : filter_mods (r2:rs)
- rs -> rs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/85c77da0c08c847f1842bd5a3ed241ff0353a2cf...3b85f87f0734015bd36cd32b630d59dfd6a115ae
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/85c77da0c08c847f1842bd5a3ed241ff0353a2cf...3b85f87f0734015bd36cd32b630d59dfd6a115ae
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230123/22882fc9/attachment-0001.html>
More information about the ghc-commits
mailing list