[Git][ghc/ghc][wip/jeltsch/smaller-pit] 2 commits: Switch Haddock back to using full module interfaces
by Wolfgang Jeltsch (＠jeltsch) 01 Oct '26
by Wolfgang Jeltsch (＠jeltsch) 01 Oct '26
01 Oct '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/smaller-pit at Glasgow Haskell Compiler / GHC
Commits:
30807924 by Wolfgang Jeltsch at 2026-10-01T23:36:02+03:00
Switch Haddock back to using full module interfaces
- - - - -
d98c999b by Wolfgang Jeltsch at 2026-10-01T23:47:17+03:00
Exclude declarations and instances from retention again
- - - - -
3 changed files:
- compiler/GHC/Unit/Module/ModIface.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
Changes:
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -84,6 +84,8 @@ module GHC.Unit.Module.ModIface
, IfaceAnnotationsData
, IfaceDeclsData
, IfaceDefaultsData
+ , IfaceClsInstsData
+ , IfaceFamInstsData
, IfaceRulesData
, IfaceCompleteMatchesData
, IfaceAbiHashesData
@@ -268,13 +270,23 @@ type family IfaceAnnotationsData (phase :: ModIfacePhase) where
type family IfaceDeclsData (phase :: ModIfacePhase) where
IfaceDeclsData 'ModIfaceCore = [IfaceDecl]
IfaceDeclsData 'ModIfaceFinal = [(Fingerprint, IfaceDecl)]
- IfaceDeclsData 'ModIfaceRetained = [IfaceDecl]
+ IfaceDeclsData 'ModIfaceRetained = ()
type family IfaceDefaultsData (phase :: ModIfacePhase) where
IfaceDefaultsData 'ModIfaceCore = [IfaceDefault]
IfaceDefaultsData 'ModIfaceFinal = [IfaceDefault]
IfaceDefaultsData 'ModIfaceRetained = ()
+type family IfaceClsInstsData (phase :: ModIfacePhase) where
+ IfaceClsInstsData 'ModIfaceCore = [IfaceClsInst]
+ IfaceClsInstsData 'ModIfaceFinal = [IfaceClsInst]
+ IfaceClsInstsData 'ModIfaceRetained = ()
+
+type family IfaceFamInstsData (phase :: ModIfacePhase) where
+ IfaceFamInstsData 'ModIfaceCore = [IfaceFamInst]
+ IfaceFamInstsData 'ModIfaceFinal = [IfaceFamInst]
+ IfaceFamInstsData 'ModIfaceRetained = ()
+
type family IfaceRulesData (phase :: ModIfacePhase) where
IfaceRulesData 'ModIfaceCore = [IfaceRule]
IfaceRulesData 'ModIfaceFinal = [IfaceRule]
@@ -403,9 +415,9 @@ data IfacePublic_ phase = IfacePublic {
-- Instance declarations and rules
- mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance
- mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances
- mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules
+ mi_insts_ :: IfaceClsInstsData phase, -- ^ Sorted class instance
+ mi_fam_insts_ :: IfaceFamInstsData phase, -- ^ Sorted family instances
+ mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules
mi_trust_ :: IfaceTrustInfo,
@@ -841,8 +853,8 @@ emptyIfaceModInfo mod = IfaceModInfo
emptyPublicModIface :: IfaceAnnotationsData phase
-> IfaceDeclsData phase
-> IfaceDefaultsData phase
- -> [IfaceClsInst]
- -> [IfaceFamInst]
+ -> IfaceClsInstsData phase
+ -> IfaceFamInstsData phase
-> IfaceRulesData phase
-> IfaceCompleteMatchesData phase
-> IfaceAbiHashesData phase
@@ -920,6 +932,8 @@ instance ( NFData (IfaceSelfRecompData phase)
, NFData (IfaceAnnotationsData phase)
, NFData (IfaceDeclsData phase)
, NFData (IfaceDefaultsData phase)
+ , NFData (IfaceClsInstsData phase)
+ , NFData (IfaceFamInstsData phase)
, NFData (IfaceRulesData phase)
, NFData (IfaceCompleteMatchesData phase)
, NFData (IfaceAbiHashesData phase)
@@ -958,6 +972,8 @@ instance NFData IfaceAbiHashes where
instance ( NFData (IfaceAnnotationsData phase)
, NFData (IfaceDeclsData phase)
, NFData (IfaceDefaultsData phase)
+ , NFData (IfaceClsInstsData phase)
+ , NFData (IfaceFamInstsData phase)
, NFData (IfaceRulesData phase)
, NFData (IfaceCompleteMatchesData phase)
, NFData (IfaceAbiHashesData phase)
@@ -1068,8 +1084,10 @@ shrinkIfacePublic IfacePublic {..}
= IfacePublic
{
mi_anns_ = (),
- mi_decls_ = map snd mi_decls_,
+ mi_decls_ = (),
mi_defaults_ = (),
+ mi_insts_ = (),
+ mi_fam_insts_ = (),
mi_rules_ = (),
mi_complete_matches_ = (),
..
@@ -1116,10 +1134,10 @@ set_mi_warns val = set_mi_public (\iface -> iface { mi_warns_ = val })
set_mi_anns :: IfaceAnnotationsData phase -> ModIface_ phase -> ModIface_ phase
set_mi_anns val = set_mi_public (\iface -> iface { mi_anns_ = val })
-set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase
+set_mi_insts :: IfaceClsInstsData phase -> ModIface_ phase -> ModIface_ phase
set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val })
-set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase
+set_mi_fam_insts :: IfaceFamInstsData phase -> ModIface_ phase -> ModIface_ phase
set_mi_fam_insts val = set_mi_public (\iface -> iface { mi_fam_insts_ = val })
set_mi_rules :: IfaceRulesData phase -> ModIface_ phase -> ModIface_ phase
@@ -1291,8 +1309,8 @@ pattern ModIface ::
-> IfaceSimplifiedCoreData phase
-> IfaceDefaultsData phase
-> IfaceTopEnv
- -> [IfaceClsInst]
- -> [IfaceFamInst]
+ -> IfaceClsInstsData phase
+ -> IfaceFamInstsData phase
-> IfaceRulesData phase
-> IfaceTrustInfo
-> Bool
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -75,7 +75,7 @@ import GHC.Unit.Home.PackageTable
import GHC.Unit.Module (getModuleInstantiation)
import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..))
import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.ModIface (RetainedModIface, shrinkModIface, mi_semantic_module, mi_boot)
+import GHC.Unit.Module.ModIface (ModIface, mi_semantic_module, mi_boot)
import GHC.Unit.Module.ModSummary (isBootSummary)
import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text)
import GHC.Utils.Error (withTiming)
@@ -255,7 +255,7 @@ dropErr :: MaybeErr e a -> Maybe a
dropErr (Succeeded a) = Just a
dropErr (Failed _) = Nothing
-loadHiFile :: Verbosity -> HscEnv -> Outputable.SDoc -> Module -> IO (RetainedModIface, ([ClsInst], [FamInst]))
+loadHiFile :: Verbosity -> HscEnv -> Outputable.SDoc -> Module -> IO (ModIface, ([ClsInst], [FamInst]))
loadHiFile verbosity hsc_env doc requested = initIfaceLoad hsc_env $ do
let installed = fst (getModuleInstantiation requested)
iface_fetch_result <- liftIO $ findAndReadIface hsc_env doc installed requested NotBoot
@@ -268,7 +268,7 @@ loadHiFile verbosity hsc_env doc requested = initIfaceLoad hsc_env $ do
new_eps_insts <- mapM tcIfaceInst (mi_insts mod_iface)
new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts mod_iface)
pure (new_eps_insts, new_eps_fam_insts)
- pure (shrinkModIface mod_iface, insts)
+ pure (mod_iface, insts)
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> WarningMap -> Ghc (Maybe Interface)
processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do
@@ -290,7 +290,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do
let cls_insts = instEnvElts . md_insts $ hm_details hmi
fam_insts = md_fam_insts $ hm_details hmi
- pure (shrinkModIface (hm_iface hmi), (cls_insts, fam_insts))
+ pure (hm_iface hmi, (cls_insts, fam_insts))
!interface <- do
logger <- getLogger
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -81,7 +81,7 @@ createInterface1
=> [Flag]
-> UnitState
-> ModSummary
- -> RetainedModIface
+ -> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
@@ -105,7 +105,7 @@ createInterface1'
-> UnitState
-> DynFlags
-> FilePath
- -> RetainedModIface
+ -> ModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
@@ -150,7 +150,7 @@ createInterface1' flags unit_state dflags hie_file mod_iface ifaces inst_ifaces
def_meths_env = mkOccEnv def_meths
def_meths =
[ (nameOccName nm, nm)
- | IfaceId{ifName = nm} <- mi_decls mod_iface
+ | (_, IfaceId{ifName = nm}) <- mi_decls mod_iface
, let occ = nameOccName nm
, isDefaultMethodOcc occ
]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ec432d89b83147adbe7d6272952d62…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ec432d89b83147adbe7d6272952d62…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/jeltsch/smaller-pit] Make Haddock avoid the PIT
by Wolfgang Jeltsch (＠jeltsch) 01 Oct '26
by Wolfgang Jeltsch (＠jeltsch) 01 Oct '26
01 Oct '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/smaller-pit at Glasgow Haskell Compiler / GHC
Commits:
ec432d89 by Wolfgang Jeltsch at 2026-10-01T23:26:12+03:00
Make Haddock avoid the PIT
- - - - -
1 changed file:
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.Driver.Session hiding (verbosity)
import GHC.Driver.Phases
import GHC.Driver.Pipeline (compileFile)
import GHC.HsToCore.Docs (getMainDeclBinder)
-import GHC.Iface.Load (loadSysInterface)
+import GHC.Iface.Load (findAndReadIface)
import GHC.IfaceToCore (tcIfaceInst, tcIfaceFamInst)
import GHC.Tc.Utils.Monad (initIfaceLoad, initIfaceLcl)
import GHC.Tc.Utils.Env (lookupGlobal_maybe)
@@ -72,6 +72,7 @@ import GHC.Types.Name.Occurrence (emptyOccEnv)
import GHC.Unit.Finder (findImportedModule, ModuleLookupScope(..), FindResult(Found))
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
+import GHC.Unit.Module (getModuleInstantiation)
import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..))
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModIface (RetainedModIface, shrinkModIface, mi_semantic_module, mi_boot)
@@ -254,19 +255,20 @@ dropErr :: MaybeErr e a -> Maybe a
dropErr (Succeeded a) = Just a
dropErr (Failed _) = Nothing
-loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (RetainedModIface, ([ClsInst], [FamInst]))
-loadHiFile hsc_env doc theModule = initIfaceLoad hsc_env $ do
-
- mod_iface <- loadSysInterface doc theModule
-
- insts <- initIfaceLcl (mi_semantic_module mod_iface) doc (mi_boot mod_iface) $ do
-
- new_eps_insts <- mapM tcIfaceInst (mi_insts mod_iface)
- new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts mod_iface)
-
- pure (new_eps_insts, new_eps_fam_insts)
-
- pure (mod_iface, insts)
+loadHiFile :: Verbosity -> HscEnv -> Outputable.SDoc -> Module -> IO (RetainedModIface, ([ClsInst], [FamInst]))
+loadHiFile verbosity hsc_env doc requested = initIfaceLoad hsc_env $ do
+ let installed = fst (getModuleInstantiation requested)
+ iface_fetch_result <- liftIO $ findAndReadIface hsc_env doc installed requested NotBoot
+ case iface_fetch_result of
+ Failed _ -> do
+ out verbosity normal "Interface fetching failed"
+ liftIO exitFailure
+ Succeeded (mod_iface, _) -> do
+ insts <- initIfaceLcl (mi_semantic_module mod_iface) doc (mi_boot mod_iface) $ do
+ new_eps_insts <- mapM tcIfaceInst (mi_insts mod_iface)
+ new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts mod_iface)
+ pure (new_eps_insts, new_eps_fam_insts)
+ pure (shrinkModIface mod_iface, insts)
processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> WarningMap -> Ghc (Maybe Interface)
processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do
@@ -279,7 +281,7 @@ processModule verbosity modSummary flags ifaceMap instIfaceMap warningMap = do
unit_state = hsc_units hsc_env
(mod_iface, insts) <- if Flag_NoCompilation `elem` flags
- then liftIO $ loadHiFile hsc_env doc $ ms_mod modSummary
+ then liftIO $ loadHiFile verbosity hsc_env doc $ ms_mod modSummary
else do
hmi <- liftIO $ lookupHpt (hsc_HPT hsc_env) (moduleName $ ms_mod modSummary) >>= \case
Nothing -> error "processModule: All modules should be loaded into the HPT by this point"
@@ -374,7 +376,7 @@ createOneShotIface verbosity flags instIfaceMap moduleNameStr = do
modifySession $ hscSetFlags dflags
hsc_env <- getSession
- (iface, insts) <- liftIO $ loadHiFile hsc_env doc $ mkMainModule_ moduleNm
+ (iface, insts) <- liftIO $ loadHiFile verbosity hsc_env doc $ mkMainModule_ moduleNm
-- Update the DynFlags with the extensions from the source file (as stored in the interface file)
-- This is instead of ms_hspp_opts from ModSummary, which is not available in one-shot mode.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec432d89b83147adbe7d6272952d62e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec432d89b83147adbe7d6272952d62e…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: RTS: Update flag parsing/handling:
by Marge Bot (＠marge-bot) 01 Oct '26
by Marge Bot (＠marge-bot) 01 Oct '26
01 Oct '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c406135c by Andreas Klebinger at 2026-10-01T06:57:28-04:00
RTS: Update flag parsing/handling:
Using 0 as argument to any of these flags now resets the flags setting to default:
- ``-n0`` disables nursery chunking.
- ``-K0`` (or a bare ``-K``) removes the stack size limit.
- ``-M0`` removes the heap size limit.
- ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``.
- ``-AL0`` makes the large object allocation limit follow ``-A`` again.
GC Generations are now limited to 64.
-n larger than -A now emits a warning and disables chunking.
Fixes #27830 #27829
- - - - -
984ee82b by Andreas Klebinger at 2026-10-01T06:58:10-04:00
Fix MultiLayerModules timeout multiplier.
We accidentally used the compile multiplier for ghci commands which
use the run timeout setting to set the timeout.
Fixes #26263 and #27796.
- - - - -
50a9cf26 by Andreas Klebinger at 2026-10-01T06:58:10-04:00
testsuite: Include runtime in JUnit report.
- - - - -
e358619f by Alan Zimmerman at 2026-10-01T06:59:01-04:00
EPA: Use EpaLocation in EpVirtualBraces
Haddock processing uses EpLayout.EpVirtualBraces to record the current
layout column, for allocating haddock comments correctly.
For exact printing, we need the line as well as the col, so we know
how many lines to skip when the indented code block starts.
This commit updates EpLayout.EpVirtualBraces so that it carries an
EpaLocation instead of just the Int column, to allow it to be used for
both purposes.
It is a simple mechanical change, with no other impact, but it allows
us to use EpLayout instead of AnnListLayout in AnnList, in the next
commit in this series.
- - - - -
f0bebd4c by Andrew Lelechenko at 2026-10-01T16:01:39-04:00
Remove bitSize from MINIMAL pragma of class Bits
Cf. https://github.com/haskell/core-libraries-committee/issues/441
The function is deprecated for 12 years and has a default implementation,
yet it was never removed from the MINIMAL pragma, putting library authors
in a very awkward position. Let's finally remove bitSize from MINIMAL.
- - - - -
79d23053 by Hannes Siebenhandl at 2026-10-01T16:01:41-04:00
Add regression test for #27641
- - - - -
8515790b by Hannes Siebenhandl at 2026-10-01T16:01:41-04:00
Don't `:add` modules the loader will reject
Only home modules can be actually added to the loader context, thus we
only accept the module if it belongs to a home unit.
- - - - -
49 changed files:
- + changelog.d/27641
- + changelog.d/T27830-rts-flag-bounds
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- docs/users_guide/runtime_control.rst
- ghc/GHCi/UI.hs
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Bits.hs
- rts/RtsFlags.c
- rts/include/rts/Flags.h
- rts/include/rts/storage/GC.h
- rts/sm/GC.c
- rts/sm/Storage.c
- testsuite/driver/junit.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- + testsuite/tests/ghci/scripts/T27641.script
- + testsuite/tests/ghci/scripts/T27641.stderr
- + testsuite/tests/ghci/scripts/T27641.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/rts/rtsflags001.stderr-ws-32
- testsuite/tests/rts/rtsflags001.stderr-ws-64
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e925a85887ebed4b4b921e49d590a9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e925a85887ebed4b4b921e49d590a9…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-27
by Alan Zimmerman (＠alanz) 01 Oct '26
by Alan Zimmerman (＠alanz) 01 Oct '26
01 Oct '26
Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-27 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-27
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/T27731] Simplify the error-suppression mechanism in GHC.Tc.Errors
by Simon Peyton Jones (＠simonpj) 01 Oct '26
by Simon Peyton Jones (＠simonpj) 01 Oct '26
01 Oct '26
Simon Peyton Jones pushed to branch wip/T27731 at Glasgow Haskell Compiler / GHC
Commits:
63f06874 by Simon Peyton Jones at 2026-10-01T17:49:26+01:00
Simplify the error-suppression mechanism in GHC.Tc.Errors
In `GHC.Tc.Errors.reportWanteds` we suppress some errors in favour of
others. But the mechanism had grown crufty, and #27331 exposed a bug.
This MR makes it simpler and more uniform, by doing everything via
the `ei_suppress` field of the ErrorItem.
Claude then found another closely-related bug (see the review linked
on !16564). That bug is immortalised in new test T18851d.
I'm still not happy with `ignoreConstraint` but we can worry about
that another day; I have not touched it.
Main changes
* Instead of /predicting/ when an error will be reported, we set
`cec_error_reported` when an error is /actually/ reported. (I renamed
it from `cec_suppress` to reflect this change.)
Now errors are suppressed only when a preceding error has actually been
reported. Simpler and more robust.
See `Note [cec_error_reported: suppressing less-serious errors]`
The big changes are in `reportWanteds` which looks very different.
* New `Note [ei_suppress: suppressing confusing errors]` describes the
(quite separate) `ei_suppress` mechanism for suppressing confusing
errors, mainly arising from non-empty rewriter sets
* In `tryTypeClassDefaulting`, instead of switching off type-class defaulting
if there is an insoluble /anywhere/, we just switch it off locally when
we find an insoluble sub-tree. See Note [When to do type-class defaulting]
and (W5) in Note [ApproximateWC]
* Greatly simplify `insolubleWantedCt`.
* I made type-class-defaulting be a bit more eager, only switched off when
a peer or ancestor (but not child) constraint is insoluble. See
Note [When to do type-class defaulting].
Small refactorings
* Rename `askNoErrs` to `askErrsFound` and flip its polarity
* The code for "check if ei_suppress is true of all items" code is
moved to `mkErrorItems` rather than in the large `reportWanteds`.
* Code for `has_gadt_match` moves to `mkGivenErrorReporter`, rather than
polluting the large `reportWanteds`.
* Many tests with `-fdefer-type-errors` get more warnings, especially
about ambiguous (Num a) constraints. This is by-design: see
Note [Always warn with -fdefer-type-errors]. Previously GHC was not
honouring this Note but now it is, hence the extra errors.
- - - - -
51 changed files:
- + changelog.d/T27731
- compiler/GHC/Builtin/WiredIn/Ids.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Monad.hs
- testsuite/tests/ghci/prog020/ghci.prog020a.stderr
- testsuite/tests/ghci/prog020/ghci.prog020b.stderr
- testsuite/tests/ghci/prog021/prog021a.stderr
- testsuite/tests/ghci/prog021/prog021b.stderr
- testsuite/tests/ghci/prog022/ghci.prog022a.stderr
- testsuite/tests/ghci/prog022/ghci.prog022b.stderr
- testsuite/tests/ghci/prog022/ghci.prog022c.stderr
- testsuite/tests/ghci/prog022/ghci.prog022d.stderr
- testsuite/tests/ghci/prog022/ghci.prog022e.stderr
- testsuite/tests/ghci/prog022/ghci.prog022f.stderr
- testsuite/tests/ghci/scripts/Defer02.stderr
- testsuite/tests/module/mod130.stderr
- testsuite/tests/overloadedstrings/should_fail/T25926.stderr
- testsuite/tests/overloadedstrings/should_fail/T27124.stderr
- testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/rename/should_fail/T15607.stderr
- testsuite/tests/rename/should_fail/T19843b.stderr
- testsuite/tests/safeHaskell/ghci/p4.stderr
- testsuite/tests/safeHaskell/ghci/p6.stderr
- testsuite/tests/typecheck/should_compile/T11254.stderr
- testsuite/tests/typecheck/should_compile/T15370.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/ClassOperator.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion3.stderr
- testsuite/tests/typecheck/should_fail/FunDepOrigin1b.hs
- testsuite/tests/typecheck/should_fail/T18851.stderr
- + testsuite/tests/typecheck/should_fail/T18851e.hs
- + testsuite/tests/typecheck/should_fail/T18851e.stderr
- testsuite/tests/typecheck/should_fail/T22940.stderr
- testsuite/tests/typecheck/should_fail/T26823.stderr
- + testsuite/tests/typecheck/should_fail/T27731.hs
- + testsuite/tests/typecheck/should_fail/T27731.stderr
- testsuite/tests/typecheck/should_fail/T5691.stderr
- testsuite/tests/typecheck/should_fail/T7437.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/mc24.stderr
- testsuite/tests/typecheck/should_fail/tcfail019.stderr
- testsuite/tests/typecheck/should_fail/tcfail189.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63f0687417b7e514d9b842b58e3832a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63f0687417b7e514d9b842b58e3832a…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/dep-json] 2 commits: New json output schema that works with multiple home units
by Hannes Siebenhandl (＠fendor) 01 Oct '26
by Hannes Siebenhandl (＠fendor) 01 Oct '26
01 Oct '26
Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC
Commits:
ec0db48d by fendor at 2026-10-01T18:01:31+02:00
New json output schema that works with multiple home units
Update testsuite
- - - - -
f694e986 by fendor at 2026-10-01T18:01:50+02:00
Add support for multiple home units
- - - - -
10 changed files:
- compiler/GHC/Driver/MakeFile.hs
- ghc/Main.hs
- testsuite/driver/testlib.py
- testsuite/tests/driver/T24384/Makefile
- testsuite/tests/driver/T24384/T24384a.stdout
- testsuite/tests/driver/T24384/T24384b.stdout
- + testsuite/tests/driver/T24384/T24384b.stdout-mingw
- + testsuite/tests/driver/T24384/T24384c.stdout
- testsuite/tests/driver/T24384/all.T
- + testsuite/tests/driver/T24384/format_json.sh
Changes:
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -11,7 +11,8 @@
{-# LANGUAGE RecordWildCards #-}
module GHC.Driver.MakeFile
- ( doMkDependHS
+ ( doMkDepend
+ , doMkDependHS
, doMkDependModuleGraph
)
where
@@ -80,6 +81,8 @@ import System.IO.Error (isEOFError)
import qualified System.OsString as OsString
import qualified Data.Monoid as Monoid
import qualified System.FilePath as FilePath
+import GHC.Unit.Home.Graph (HomeUnitEnv(homeUnitEnv_dflags))
+import GHC (setProgramHUG)
-----------------------------------------------------------------
--
@@ -117,7 +120,39 @@ doMkDependHS srcs = do
module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
doMkDependModuleGraph dflags module_graph
+doMkDepend :: GhcMonad m => m ()
+doMkDepend = do
+ hug_ <- hsc_HUG <$> getSession
+
+ let hug =
+ fmap (\ hue ->
+ let
+ -- We kludge things a bit for dependency generation. Rather than
+ -- generating dependencies for each way separately, we generate
+ -- them once and then duplicate them for each way's osuf/hisuf.
+ -- We therefore do the initial dependency generation with an empty
+ -- way and .o/.hi extensions, regardless of any flags that might
+ -- be specified.
+ dflags1 = (homeUnitEnv_dflags hue)
+ { targetWays_ = Set.empty
+ , hiSuf_ = "hi"
+ , objectSuf_ = "o"
+ }
+ in
+ hue {homeUnitEnv_dflags = dflags1}
+ ) hug_
+
+ _ <- setProgramHUG hug
+
+ dflagsGlobal <- GHC.getSessionDynFlags
+ -- If no suffix is provided, use the default -- the empty one
+ let dflags = if null (depSuffixes dflagsGlobal)
+ then dflagsGlobal { depSuffixes = [""] }
+ else dflagsGlobal
+ let excl_mods = depExcludeMods dflags
+ module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
+ doMkDependModuleGraph dflags module_graph
doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m ()
doMkDependModuleGraph dflags module_graph = do
@@ -610,127 +645,188 @@ writeJsonFile doc p = do
--------------------------------------------------------------------------------
-- Payload for -dep-json
-newtype PackageDeps
- = PackageDeps (Map.Map (String, UnitId, DPackageId) DepsImports)
- deriving newtype (Monoid)
-
newtype DPackageId = DPackageId PackageId
deriving newtype (Eq)
instance Ord DPackageId where
DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2
-instance Semigroup PackageDeps where
- PackageDeps l <> PackageDeps r = PackageDeps (Map.unionWith (Semigroup.<>) l r)
-
-data Deps = Deps
- { sources :: Set.Set OsPath
- , moduleImports :: DepsImports
- , sourceImports :: DepsImports
- , packages :: PackageDeps
+data ModuleNodeDeps = ModuleNodeDeps
+ { source :: OsPath
+ , imports :: ImportDeps
, cpp :: Set.Set OsPath
, options :: [String]
, preprocessor :: Maybe FilePath
}
deriving stock (Generic)
- deriving (Semigroup, Monoid) via (Generically Deps)
+ deriving (Semigroup, Monoid) via (Generically ModuleNodeDeps)
-data DepsImports
- = DepsImports
- { normalImport :: Set.Set Module
- , spliceImport :: Set.Set Module
- , quoteImport :: Set.Set Module
- }
+addImport :: ImportDep -> ModuleNodeDeps -> ModuleNodeDeps
+addImport import_dep mod_node_deps =
+ mod_node_deps
+ { imports = ImportDeps $ Map.insertWith Set.union uid (Set.singleton import_dep) (getImports $ imports mod_node_deps)
+ }
+ where
+ uid = toUnitId $ moduleUnit $ imp_mod import_dep
+
+addCpp :: OsPath -> ModuleNodeDeps -> ModuleNodeDeps
+addCpp p mod_node_deps =
+ mod_node_deps
+ { cpp = Set.insert p (cpp mod_node_deps)
+ }
+
+newtype ImportDeps = ImportDeps { getImports :: Map.Map UnitId (Set.Set ImportDep) }
deriving stock (Generic)
- deriving (Semigroup, Monoid) via (Generically DepsImports)
+ deriving (Semigroup, Monoid) via (Generically ImportDeps)
+
+data ImportDep = ImportDep
+ { imp_mod :: Module
+ , imp_level :: ImportLevel
+ , imp_isBoot :: IsBootInterface
+ } deriving (Eq, Ord)
+
+mkImportDep :: Module -> ImportLevel -> IsBootInterface -> ImportDep
+mkImportDep modl level isBoot = ImportDep
+ { imp_mod = modl
+ , imp_level = level
+ , imp_isBoot = isBoot
+ }
-newtype DepJson = DepJson (Map.Map ModuleWithIsBoot Deps)
+data HomeUnitDeps = HomeUnitDeps
+ { homeModules :: Map.Map ModuleWithIsBoot ModuleNodeDeps
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically HomeUnitDeps)
+
+data ExtUnitDep = ExtUnitDep
+ { extUnitId :: UnitId
+ -- ^ The 'UnitId' of a unit. This is assumed to be globally unique.
+ , extUnitName :: String
+ , extUnitPackageId :: DPackageId
+ } deriving (Eq, Ord)
+
+data DepJson = DepJson
+ { homeUnitDeps :: Map.Map UnitId HomeUnitDeps
+ , externalDeps :: Set.Set ExtUnitDep
+ }
instance ToJson DepJson where
- json (DepJson m) =
- JSObject
- [ (homeUnitModuleKey target, homeUnitModule deps)
- | (target, deps) <- Map.toList m
+ json (DepJson homeUnits extDeps) =
+ JSObject $
+ [ homeUnit huid hud
+ | (huid, hud) <- Map.toList homeUnits
+ ] ++
+ [ mkExtDepObj dep
+ | dep <- Set.toList extDeps
]
where
+ homeUnit uid hud =
+ ( unitIdString uid
+ , JSObject
+ [
+ ( "modules"
+ , JSObject
+ [ (homeUnitModuleKey modl, homeUnitModule deps)
+ | (modl, deps) <- Map.toList $ homeModules hud
+ ]
+ )
+ ]
+ )
+
homeUnitModuleKey :: ModuleWithIsBoot -> String
- homeUnitModuleKey t = moduleNameString (moduleName (gwib_mod t)) ++ case gwib_isBoot t of
+ homeUnitModuleKey t = moduleKey (gwib_mod t) (gwib_isBoot t)
+
+ moduleKey :: Module -> IsBootInterface -> String
+ moduleKey t b = moduleNameString (moduleName t) ++ case b of
IsBoot -> "[boot]"
NotBoot -> ""
- homeUnitModule :: Deps -> JsonDoc
- homeUnitModule Deps {packages = PackageDeps packages, ..} =
+ homeUnitModule :: ModuleNodeDeps -> JsonDoc
+ homeUnitModule ModuleNodeDeps {source, imports, cpp, options, preprocessor} =
JSObject
- [ ("sources", array sources (showOsPath . normalise))
- , ("modules", JSObject $ importsObj moduleImports)
- , ("modules-boot", JSObject $ importsObj sourceImports)
- , ("packages", JSArray
- [ package name unit_id package_id mods
- | ((name, unit_id, dpkd_id), mods) <- Map.toList packages
- , let DPackageId package_id = dpkd_id
- ]
- )
- , ("cpp", array cpp showOsPath)
+ [ ("source", JSString . showOsPath $ normalise source)
+ , ("imports", importsObj imports)
+ , ("includes", strArray cpp showOsPath)
, ("options", JSArray $ map JSString options)
, ("preprocessor", maybe JSNull JSString preprocessor)
]
- package :: String -> UnitId -> PackageId -> DepsImports -> JsonDoc
- package name unit_id (PackageId package_id) mods =
+ importsObj :: ImportDeps -> JsonDoc
+ importsObj importDeps = JSArray $ map importObj (Map.toList $ getImports importDeps)
+
+ importObj :: (UnitId, Set.Set ImportDep) -> JsonDoc
+ importObj (uid, importSet) =
JSObject
- [ ("id", JSString (unitIdString unit_id))
- , ("name", JSString name)
- , ("package-id", JSString (unpackFS package_id))
- , ("modules", JSObject $ importsObj mods)
+ [ (unitIdString uid, array importSet importDepObj )
]
- array values render = JSArray (fmap (JSString . render) (Set.toList values))
+ importDepObj :: ImportDep -> JsonDoc
+ importDepObj ImportDep {imp_mod, imp_level, imp_isBoot}
+ | NormalLevel <- imp_level = JSString (moduleKey imp_mod imp_isBoot)
+ | otherwise = JSObject
+ [ ("module", JSString (moduleKey imp_mod imp_isBoot))
+ , ("level" , importLevel imp_level)
+ ]
- showOsPath = unsafeDecodeUtf
+ importLevel :: ImportLevel -> JsonDoc
+ importLevel lvl =
+ JSString $ case lvl of
+ NormalLevel -> "normal"
+ SpliceLevel -> "splice"
+ QuoteLevel -> "quote"
+
+ mkExtDepObj :: ExtUnitDep -> (String, JsonDoc)
+ mkExtDepObj ExtUnitDep{..} =
+ ( unitIdString extUnitId
+ , JSObject
+ [ ("package-name", JSString extUnitName)
+ , ("package-id", JSString $ showPackageId extUnitPackageId)
+ ]
+ )
+
+ array values render = JSArray (fmap render (Set.toList values))
+ strArray values render = JSArray (fmap (JSString . render) (Set.toList values))
- importsObj :: DepsImports -> [(String, JsonDoc)]
- importsObj DepsImports{..} =
- [ ("normal", array normalImport (moduleNameString . moduleName))
- , ("quote" , array quoteImport (moduleNameString . moduleName))
- , ("splice", array spliceImport (moduleNameString . moduleName))
- ]
+ showOsPath = unsafeDecodeUtf
+ showPackageId (DPackageId (PackageId pid)) = unpackFS pid
initDepJson :: IO (IORef DepJson)
-initDepJson = newIORef $ DepJson Map.empty
+initDepJson = newIORef $ DepJson Map.empty Set.empty
-insertDepJson :: [ModuleWithIsBoot] -> Deps -> DepJson -> DepJson
-insertDepJson targets dep (DepJson m0) =
+insertDepJson :: ModuleWithIsBoot -> ModuleNodeDeps -> Set.Set ExtUnitDep -> DepJson -> DepJson
+insertDepJson target modNode extUnits (DepJson m0 e0) =
DepJson
- $ foldl'
- ( \acc target ->
- Map.insertWithKey
- (\ k _l _r -> pprPanic "insertDepJson" (text "Conflicting entries for: " <+> ppr k))
- target
- dep
- acc
- )
- m0
- targets
+ { homeUnitDeps =
+ Map.insertWith
+ (Semigroup.<>)
+ modUnitId
+ (HomeUnitDeps $ Map.singleton target modNode)
+ m0
+ , externalDeps =
+ Set.union e0 extUnits
+ }
+ where
+ modUnitId = toUnitId $ moduleUnit $ gwib_mod target
updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
updateDepJson include_pkgs DepNode {..} deps =
- insertDepJson [dn_mod] payload
+ insertDepJson dn_mod payload externalDeps
where
- payload = node_data Semigroup.<> foldMap mkDep deps
+ (externalDeps, payload) = foldl' go (Set.empty, initial_node_data) deps
- node_data =
- mempty
- { sources = Set.singleton dn_src
+ initial_node_data =
+ ModuleNodeDeps
+ { source = dn_src
, preprocessor = pn_preprocessor dn_preprocessing
, options = pn_options dn_preprocessing
+ , cpp = Set.empty
+ , imports = ImportDeps Map.empty
}
- mkDep = \case
+ go (extDeps, node_data) = \ case
DepHi {dep_mod, dep_local, dep_unit, dep_boot, dep_level}
| dep_local
- -> case dep_boot of
- IsBoot -> mempty {sourceImports = depsImportForImport dep_mod dep_level}
- NotBoot -> mempty {moduleImports = depsImportForImport dep_mod dep_level }
+ -> (extDeps, addImport (mkImportDep dep_mod dep_level dep_boot) node_data)
| include_pkgs
, Just unit <- dep_unit
@@ -738,19 +834,21 @@ updateDepJson include_pkgs DepNode {..} deps =
name = unpackFS nameFS
withLibName (PackageName c) = name ++ ":" ++ unpackFS c
lname = maybe name withLibName (unitComponentName unit)
- key = (lname, unitId unit, DPackageId $ unitPackageId unit)
- -> mempty {packages = PackageDeps (Map.singleton key (depsImportForImport dep_mod dep_level))}
+ newExtDep = ExtUnitDep
+ { extUnitId = unitId unit
+ , extUnitName = lname
+ , extUnitPackageId = DPackageId $ unitPackageId unit
+ }
+ ->
+ ( Set.insert newExtDep extDeps
+ , addImport (mkImportDep dep_mod dep_level dep_boot) node_data
+ )
| otherwise
- -> mempty
+ -> (extDeps, node_data)
DepCpp {dep_path} ->
- mempty {cpp = Set.singleton dep_path}
-
- depsImportForImport mod_name = \ case
- NormalLevel -> mempty { normalImport = Set.singleton mod_name }
- SpliceLevel -> mempty { spliceImport = Set.singleton mod_name }
- QuoteLevel -> mempty { quoteImport = Set.singleton mod_name }
+ (extDeps, addCpp dep_path node_data)
-----------------------------------------------------------------
-- Module cycles
=====================================
ghc/Main.hs
=====================================
@@ -27,7 +27,7 @@ import GHC.Driver.Phases
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Pipeline ( oneShot )
-import GHC.Driver.MakeFile ( doMkDependHS )
+import qualified GHC.Driver.MakeFile as MakeFile
import GHC.Driver.Backpack ( doBackpack )
import GHC.Driver.Plugins
import GHC.Driver.Config.Logger (initLogFlags)
@@ -271,7 +271,7 @@ main' postLoadMode units dflags0 args flagWarnings = do
f
ShowByteCode f -> liftIO $ showByteCode logger hsc_env f
DoMake -> doMake units srcs
- DoMkDependHS -> doMkDependHS (map fst srcs)
+ DoMkDependHS -> doMkDepend units srcs
StopBefore p -> liftIO (oneShot hsc_env p srcs)
DoInteractive -> ghciUI units srcs Nothing
DoEval exprs -> ghciUI units srcs $ Just $ reverse exprs
@@ -332,6 +332,24 @@ doMake units targets = do
ok_flag <- GHC.load LoadAllTargets
when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+-- ----------------------------------------------------------------------------
+-- Run -M mode
+
+doMkDepend :: [String] -> [(String, Maybe Phase)] -> Ghc ()
+doMkDepend units targets = do
+ hs_srcs <- case NE.nonEmpty units of
+ Just ne_units -> do
+ initMulti ne_units (checkOptions DoMake)
+ Nothing -> do
+ s <- initMake targets -- TODO: @fendor: This feels wrong
+ return $ map (uncurry (,Nothing,)) s
+ case hs_srcs of
+ [] -> return ()
+ _ -> do
+ targets' <- mapM (\(src, uid, phase) -> GHC.guessTarget src uid phase) hs_srcs
+ GHC.setTargets targets'
+ MakeFile.doMkDepend
+
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
=====================================
testsuite/driver/testlib.py
=====================================
@@ -20,6 +20,7 @@ from pathlib import Path, PurePath
import collections
import collections.abc
import subprocess
+import json
from testglobals import config, ghc_env, default_testopts, brokens, t, \
TestRun, TestResult, TestOptions, PerfMetric
@@ -3265,6 +3266,34 @@ def normalise_asm( s: str ) -> str:
out.append(ins[0])
return '\n'.join(out)
+def normalise_dep_json(s: str) -> str:
+ """
+ Normalise the json output of `ghc -M -dep-json output.json`
+ """
+
+ def normalise_includes(j):
+ # Only normalise proper json objects.
+ # Strings might be parsed as json strings, but we that's not what we are looking for
+ if not isinstance(j, dict):
+ return j
+ for unit in j.values():
+ for module in unit.get("modules", {}).values():
+ rewritten = [
+ "<absolute-path>/" + p.rsplit("/", 1)[-1] if p.startswith("/") else p
+ for p in module["includes"]
+ ]
+ # we sort to make sure this never
+ module["includes"] = sorted(rewritten)
+ return j
+
+ output = ""
+ try:
+ normalised_dep_json = normalise_includes(json.loads(s))
+ output = json.dumps(normalised_dep_json, indent=2, sort_keys=True, ensure_ascii=False)
+ except json.JSONDecodeError:
+ output = s
+ return output
+
def safe_print(s: str) -> None:
s2 = s.encode(sys.stdout.encoding, errors='replace').decode(sys.stdout.encoding)
print(s2)
=====================================
testsuite/tests/driver/T24384/Makefile
=====================================
@@ -45,4 +45,12 @@ T24384b: T24384_prep
-package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \
A.hs lib/B.hs C.hs D.hs E.hs
- cat dep.json | jq --sort-keys
+ cat dep.json
+
+T24384c: T24384_prep
+ '$(TEST_HC)' -M -dep-json dep.json \
+ -hide-all-packages -package base -package containers -package template-haskell \
+ -package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \
+ A.hs lib/B.hs C.hs D.hs E.hs
+
+ cat dep.json
=====================================
testsuite/tests/driver/T24384/T24384a.stdout
=====================================
@@ -22,6 +22,11 @@ C.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../
C.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
C.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/containers-0.8-inplace/Data/Set.hi
C.o : A.hi
+lib/B.o-boot : lib/B.hs-boot
+lib/B.o : lib/B.hi-boot
+lib/B.o-boot : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+lib/B.o-boot : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+lib/B.o-boot : A.hi
lib/B.o : lib/B.hs
lib/B.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
lib/B.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
=====================================
testsuite/tests/driver/T24384/T24384b.stdout
=====================================
@@ -1,310 +1,191 @@
{
- "A": {
- "cpp": [
- "/home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/rts-1.0.3/include/ghcversion.h",
- "/usr/include/stdc-predef.h",
- "foo.h"
- ],
- "modules": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [
- "C"
- ],
- "quote": [],
- "splice": []
- },
- "options": [
- "-XStrict",
- "-XCPP",
- "-fexpose-all-unfoldings"
- ],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
- }
- ],
- "preprocessor": null,
- "sources": [
- "A.hs"
- ]
+ "base-<VERSION>-<HASH>": {
+ "package-id": "base-<VERSION>-<HASH>",
+ "package-name": "base"
},
- "B": {
- "cpp": [],
- "modules": {
- "normal": [
- "A"
- ],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "options": [
- "-F",
- "-pgmF",
- "./preproc.sh"
- ],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
- }
- ],
- "preprocessor": "./preproc.sh",
- "sources": [
- "lib/B.hs"
- ]
+ "containers-<VERSION>-<HASH>": {
+ "package-id": "containers-<VERSION>-<HASH>",
+ "package-name": "containers"
},
- "B[boot]": {
- "cpp": [],
- "modules": {
- "normal": [
- "A"
- ],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "options": [
- "-F",
- "-pgmF",
- "./preproc.sh"
- ],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
- }
- ],
- "preprocessor": "./preproc.sh",
- "sources": [
- "lib/B.hs-boot"
- ]
+ "dep-1-XXX": {
+ "package-id": "dep-1",
+ "package-name": "dep"
},
- "C": {
- "cpp": [],
- "modules": {
- "normal": [
- "A"
- ],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "options": [],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
- },
- {
- "id": "containers-0.8-inplace",
- "modules": {
- "normal": [
- "Data.Set"
- ],
- "quote": [],
- "splice": []
- },
- "name": "containers",
- "package-id": "containers-0.8"
- }
- ],
- "preprocessor": null,
- "sources": [
- "C.hs"
- ]
+ "dep-public-1-XXX": {
+ "package-id": "dep-public-1",
+ "package-name": "dep-public"
},
- "C[boot]": {
- "cpp": [],
+ "main": {
"modules": {
- "normal": [
- "E"
- ],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "options": [],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
- }
- ],
- "preprocessor": null,
- "sources": [
- "C.hs-boot"
- ]
- },
- "D": {
- "cpp": [],
- "modules": {
- "normal": [
- "B",
- "C"
- ],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "options": [],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
- }
- ],
- "preprocessor": null,
- "sources": [
- "D.hs"
- ]
- },
- "E": {
- "cpp": [],
- "modules": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "modules-boot": {
- "normal": [],
- "quote": [],
- "splice": []
- },
- "options": [],
- "packages": [
- {
- "id": "base-4.23.0.0-inplace",
- "modules": {
- "normal": [
- "GHC.Essentials",
- "Prelude"
- ],
- "quote": [],
- "splice": []
- },
- "name": "base",
- "package-id": "base-4.23.0.0"
+ "A": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "C[boot]"
+ ]
+ }
+ ],
+ "includes": [
+ "<absolute-path>/ghcversion.h",
+ "<absolute-path>/stdc-predef.h",
+ "foo.h"
+ ],
+ "options": [
+ "-XStrict",
+ "-XCPP",
+ "-fexpose-all-unfoldings"
+ ],
+ "preprocessor": null,
+ "source": "A.hs"
},
- {
- "id": "dep-1-XXX",
- "modules": {
- "normal": [
- "Dep"
- ],
- "quote": [],
- "splice": []
- },
- "name": "dep",
- "package-id": "dep-1"
+ "B": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs"
},
- {
- "id": "dep-public-1-XXX",
- "modules": {
- "normal": [
- "DepPublic"
- ],
- "quote": [],
- "splice": []
- },
- "name": "dep-public",
- "package-id": "dep-public-1"
+ "B[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs-boot"
},
- {
- "id": "template-haskell-2.25.0.0-inplace",
- "modules": {
- "normal": [
- "Language.Haskell.TH.Syntax"
- ],
- "quote": [],
- "splice": []
- },
- "name": "template-haskell",
- "package-id": "template-haskell-2.25.0.0"
+ "C": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "containers-<VERSION>-<HASH>": [
+ "Data.Set"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs"
+ },
+ "C[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "E"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs-boot"
+ },
+ "D": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "B",
+ "C"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "D.hs"
+ },
+ "E": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "dep-1-XXX": [
+ "Dep"
+ ]
+ },
+ {
+ "dep-public-1-XXX": [
+ "DepPublic"
+ ]
+ },
+ {
+ "template-haskell-<VERSION>-<HASH>": [
+ "Language.Haskell.TH.Syntax"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "E.hs"
}
- ],
- "preprocessor": null,
- "sources": [
- "E.hs"
- ]
+ }
+ },
+ "template-haskell-<VERSION>-<HASH>": {
+ "package-id": "template-haskell-<VERSION>-<HASH>",
+ "package-name": "template-haskell"
}
}
=====================================
testsuite/tests/driver/T24384/T24384b.stdout-mingw
=====================================
@@ -0,0 +1,191 @@
+{
+ "base-<VERSION>-<HASH>": {
+ "package-id": "base-<VERSION>-<HASH>",
+ "package-name": "base"
+ },
+ "containers-<VERSION>-<HASH>": {
+ "package-id": "containers-<VERSION>-<HASH>",
+ "package-name": "containers"
+ },
+ "dep-1-XXX": {
+ "package-id": "dep-1",
+ "package-name": "dep"
+ },
+ "dep-public-1-XXX": {
+ "package-id": "dep-public-1",
+ "package-name": "dep-public"
+ },
+ "main": {
+ "modules": {
+ "A": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "C[boot]"
+ ]
+ }
+ ],
+ "includes": [
+ "<absolute-path>/ghcversion.h",
+ "<absolute-path>/stdc-predef.h",
+ "foo.h"
+ ],
+ "options": [
+ "-XStrict",
+ "-XCPP",
+ "-fexpose-all-unfoldings"
+ ],
+ "preprocessor": null,
+ "source": "A.hs"
+ },
+ "B": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs"
+ },
+ "B[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs-boot"
+ },
+ "C": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "containers-<VERSION>-<HASH>": [
+ "Data.Set"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs"
+ },
+ "C[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "E"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs-boot"
+ },
+ "D": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "B",
+ "C"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "D.hs"
+ },
+ "E": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "dep-1-XXX": [
+ "Dep"
+ ]
+ },
+ {
+ "dep-public-1-XXX": [
+ "DepPublic"
+ ]
+ },
+ {
+ "template-haskell-<VERSION>-<HASH>": [
+ "Language.Haskell.TH.Syntax"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "E.hs"
+ }
+ }
+ },
+ "template-haskell-<VERSION>-<HASH>": {
+ "package-id": "template-haskell-<VERSION>-<HASH>",
+ "package-name": "template-haskell"
+ }
+}
=====================================
testsuite/tests/driver/T24384/T24384c.stdout
=====================================
@@ -0,0 +1,104 @@
+{
+ "main": {
+ "modules": {
+ "A": {
+ "imports": [
+ {
+ "main": [
+ "C[boot]"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-XStrict",
+ "-XCPP",
+ "-fexpose-all-unfoldings"
+ ],
+ "preprocessor": null,
+ "source": "A.hs"
+ },
+ "B": {
+ "imports": [
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs"
+ },
+ "B[boot]": {
+ "imports": [
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs-boot"
+ },
+ "C": {
+ "imports": [
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs"
+ },
+ "C[boot]": {
+ "imports": [
+ {
+ "main": [
+ "E"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs-boot"
+ },
+ "D": {
+ "imports": [
+ {
+ "main": [
+ "B",
+ "C"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "D.hs"
+ },
+ "E": {
+ "imports": [],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "E.hs"
+ }
+ }
+ }
+}
=====================================
testsuite/tests/driver/T24384/all.T
=====================================
@@ -5,7 +5,11 @@ test_extras = extra_files(
'preproc.sh'
])
-normalisers = normalise_version('base', 'containers', 'template-haskell')
+normalisers = [ normalise_version('base', 'containers', 'template-haskell')
+ , normalise_slashes
+ , normalise_fun(normalise_dep_json)
+ ]
-test('T24384a', [ test_extras, normalisers, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, [])
-test('T24384b', [ test_extras, normalisers, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, [])
+test('T24384a', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep'), *normalisers ], makefile_test, [])
+test('T24384b', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep'), *normalisers ], makefile_test, [])
+test('T24384c', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep'), *normalisers ], makefile_test, [])
=====================================
testsuite/tests/driver/T24384/format_json.sh
=====================================
@@ -0,0 +1,35 @@
+#!/usr/bin/env bash
+set -euo pipefail
+
+# Packages whose ids are rewritten to <pkg>-<VERSION>-<HASH>
+pkgs='base|containers|template-haskell'
+
+usage() {
+ cat <<EOF
+Usage: $(basename "$0") FILE
+
+Format one of the test -dep-json output file with jq and normalise it:
+ - absolute paths in "includes" become <absolute-path>/<filename>,
+ and the "includes" lists are sorted
+ - ids of the packages ${packages[*]}
+ (e.g. base-4.23.0.0-inplace) become <pkg>-<VERSION>-<HASH>
+
+Writes the output to FILE
+EOF
+}
+
+case "${1:-}" in -h|--help) usage; exit 0 ;; esac
+[ $# -eq 1 ] || { usage >&2; exit 1; }
+
+# Escape regex metacharacters (and the / delimiter) for sed
+esc() { sed 's/[][\.*^$+?(){}|/]/\\&/g'; }
+
+json=$(jq --sort-keys '
+ (.. | objects | select(has("includes")) | .includes) |=
+ (map(if startswith("/") then "<absolute-path>/" + (split("/") | last) else . end) | sort)
+' "$1")
+
+tmp=$(mktemp "$1.XXXXXX")
+trap 'rm -f "$tmp"' EXIT
+sed -E "s/($pkgs)-[0-9.]+(-[0-9a-zA-Z+]+)?(-[0-9a-zA-Z]+)?/\\1-<VERSION>-<HASH>/g" <<<"$json" > "$tmp"
+mv "$tmp" "$1"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0963547e17d9fb681bddf11848ad45…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0963547e17d9fb681bddf11848ad45…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/dep-json] 6 commits: Add makefile -M test
by Hannes Siebenhandl (＠fendor) 01 Oct '26
by Hannes Siebenhandl (＠fendor) 01 Oct '26
01 Oct '26
Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC
Commits:
b2eed73f by fendor at 2026-09-25T14:48:04+02:00
Add makefile -M test
- - - - -
d87108e8 by fendor at 2026-09-25T15:58:43+02:00
Refactor Makefile to use phases appropriately
Prepare refactoring to allow json and Makefile implementation
- - - - -
01b023a0 by fendor at 2026-09-25T15:58:46+02:00
Abstract dependency processing from Makefile generation
Allows multiple consumers
- - - - -
b5351fd6 by fendor at 2026-09-25T15:58:47+02:00
Add json output format
- - - - -
663da77b by fendor at 2026-09-29T17:17:07+02:00
Add support for explicit level imports
Don't merge boot module entries with the actual sources, they can have
different imports, different preprocessors, etc...
Expand the test to include a boot module with a preprocessor
and options different to the source module.
- - - - -
0963547e by fendor at 2026-10-01T16:25:24+02:00
New json output schema that works with multiple home units
Update testsuite
- - - - -
30 changed files:
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/Phases.hs
- compiler/GHC/Driver/Session.hs
- docs/users_guide/separate_compilation.rst
- testsuite/driver/testlib.py
- + testsuite/tests/driver/T24384/A.hs
- + testsuite/tests/driver/T24384/C.hs
- + testsuite/tests/driver/T24384/C.hs-boot
- + testsuite/tests/driver/T24384/D.hs
- + testsuite/tests/driver/T24384/E.hs
- + testsuite/tests/driver/T24384/Makefile
- + testsuite/tests/driver/T24384/T24384a.stdout
- + testsuite/tests/driver/T24384/T24384b.stdout
- + testsuite/tests/driver/T24384/T24384b.stdout-mingw
- + testsuite/tests/driver/T24384/T24384c.stdout
- + testsuite/tests/driver/T24384/all.T
- + testsuite/tests/driver/T24384/dep-internal/DepInternal.hs
- + testsuite/tests/driver/T24384/dep-internal/dep-internal.pkg
- + testsuite/tests/driver/T24384/dep-public/DepPublic.hs
- + testsuite/tests/driver/T24384/dep-public/dep-public.pkg
- + testsuite/tests/driver/T24384/dep/Dep.hs
- + testsuite/tests/driver/T24384/dep/dep.pkg
- + testsuite/tests/driver/T24384/foo.h
- + testsuite/tests/driver/T24384/format_json.sh
- + testsuite/tests/driver/T24384/lib/B.hs
- + testsuite/tests/driver/T24384/lib/B.hs-boot
- + testsuite/tests/driver/T24384/preproc.sh
Changes:
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -351,6 +351,7 @@ data DynFlags = DynFlags {
-- For ghc -M
depMakefile :: FilePath,
+ depJson :: Maybe FilePath,
depIncludePkgDeps :: Bool,
depIncludeCppDeps :: Bool,
depExcludeMods :: [ModuleName],
@@ -694,6 +695,7 @@ defaultDynFlags mySettings =
-- ghc -M values
depMakefile = "Makefile",
+ depJson = Nothing,
depIncludePkgDeps = False,
depIncludeCppDeps = False,
depExcludeMods = [],
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -7,6 +7,8 @@
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Driver.MakeFile
( doMkDependHS
@@ -16,47 +18,68 @@ where
import GHC.Prelude
-import qualified GHC
-import GHC.Driver.Make
-import GHC.Driver.Monad
+import GHC qualified
+
+import GHC.Data.Bag (listToBag)
+import GHC.Data.FastString (lexicalCompareFS, unpackFS)
+import GHC.Data.Graph.Directed (SCC (..))
+import GHC.Data.OsPath
+
import GHC.Driver.DynFlags
-import GHC.Utils.Misc
import GHC.Driver.Env
import GHC.Driver.Errors.Types
-import GHC.Types.UnresolvedImport
-import qualified GHC.SysTools as SysTools
-import GHC.Data.Graph.Directed ( SCC(..) )
-import GHC.Data.OsPath (unsafeDecodeUtf)
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.SourceError
-import GHC.Types.SrcLoc
-import GHC.Types.PkgQual
-import Data.List (partition)
-import GHC.Utils.TmpFs
+import GHC.Driver.Make
+import GHC.Driver.Monad
+import GHC.Driver.Phases
+import GHC.Driver.Pipeline
+import GHC.Driver.Pipeline.Monad
+import GHC.Driver.Session
+import GHC.Iface.Errors.Types
import GHC.Iface.Load (cannotFindModule)
+import GHC.SysTools qualified as SysTools
+import GHC.Types.PkgQual
+import GHC.Types.SourceError
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.Set (UniqSet)
+import GHC.Types.Unique.Set qualified as UniqSet
+import GHC.Types.UnresolvedImport
+
+import GHC.Unit.Finder
+import GHC.Unit.Info
import GHC.Unit.Module
-import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
-import GHC.Unit.Finder
+import GHC.Unit.Module.ModSummary
+import GHC.Unit.State (lookupUnitId)
-import GHC.Utils.Exception
import GHC.Utils.Error
+import GHC.Utils.Exception
+import GHC.Utils.Json
import GHC.Utils.Logger
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.TmpFs
+import Control.Monad (when)
+import Data.Either
+import Data.Foldable (traverse_)
+import Data.IORef
+import Data.List (partition)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (isJust, isNothing)
+import Data.Semigroup qualified as Semigroup
+import Data.Set qualified as Set
+import GHC.Generics (Generic, Generically (..))
import System.Directory
-import System.FilePath
+import qualified System.Directory as Directory
+import System.OsPath as OsPath
import System.IO
-import System.IO.Error ( isEOFError )
-import Control.Monad ( when, forM_ )
-import Data.Maybe ( isJust )
-import Data.IORef
-import qualified Data.Set as Set
-import GHC.Iface.Errors.Types
-import Data.Either
-import GHC.Data.Bag (listToBag)
+import System.IO.Error (isEOFError)
+import qualified System.OsString as OsString
+import qualified Data.Monoid as Monoid
+import qualified System.FilePath as FilePath
-----------------------------------------------------------------
--
@@ -98,27 +121,47 @@ doMkDependHS srcs = do
doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m ()
doMkDependModuleGraph dflags module_graph = do
+ hsc_env <- getSession
logger <- getLogger
- tmpfs <- hsc_tmpfs <$> getSession
- let excl_mods = depExcludeMods dflags
+ let
+ tmpfs = hsc_tmpfs hsc_env
+ excl_mods = depExcludeMods dflags
- files <- liftIO $ beginMkDependHS logger tmpfs dflags
- let sorted = GHC.topSortModuleGraph False module_graph Nothing
+ root_ <- liftIO getCurrentDirectory
+ root <- encodeUtf root_
+ let
+ backends = concat
+ [ [ initFileDepWriter logger root tmpfs dflags
+ ]
+ , [ initJsonDepWriter json_output dflags
+ | Just json_output <- [depJson dflags]
+ ]
+ ]
+
+
+ let sorted = GHC.topSortModuleGraph False module_graph Nothing
-- Print out the dependencies if wanted
liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
- -- Process them one by one, dumping results into makefile
- -- and complaining about cycles
- hsc_env <- getSession
- root <- liftIO getCurrentDirectory
- mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
+ liftIO $ do
+
+ -- Setup the writers
+ writers <- sequenceA backends
+ sinks <- traverse dw_beginWriter writers
+
+ -- Do the actual work
+ do
+ -- Process them one by one, dumping results and complaining about cycles
+ mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) sinks) sorted
- -- If -ddump-mod-cycles, show cycles in the module graph
- liftIO $ dumpModCycles logger module_graph
+ -- If -ddump-mod-cycles, show cycles in the module graph
+ liftIO $ dumpModCycles logger module_graph
+
+ -- Tidy up
+ do
+ traverse_ dw_endWriter writers
- -- Tidy up
- liftIO $ endMkDependHS logger files
-- Unconditional exiting is a bad idea. If an error occurs we'll get an
--exception; if that is not caught it's fine, but at least we have a
@@ -127,6 +170,200 @@ doMkDependModuleGraph dflags module_graph = do
--`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
+--------------------------------------------------------------------------------
+-- Types abstracting over the output
+--------------------------------------------------------------------------------
+
+data DepNode =
+ DepNode
+ { dn_mod :: ModuleWithIsBoot
+ , dn_src :: OsPath
+ , dn_obj :: OsPath
+ , dn_hi :: OsPath
+ , dn_preprocessing :: PreprocessingNode
+ }
+
+data PreprocessingNode = PreprocessingNode
+ { pn_preprocessor :: Maybe String
+ , pn_options :: [String]
+ }
+
+data Dep
+ = DepHi
+ { dep_mod :: Module
+ , dep_path :: OsPath
+ , dep_unit :: Maybe UnitInfo
+ , dep_local :: Bool
+ , dep_level :: ImportLevel
+ , dep_boot :: IsBootInterface
+ }
+ | DepCpp
+ { dep_path :: OsPath
+ }
+
+data DependencyWriter = DependencyWriter
+ { dw_beginWriter :: IO DepSink
+ , dw_endWriter :: IO ()
+ }
+
+data DepSink = DepSink
+ { ds_writeDependency :: DepNode -> [Dep] -> IO ()
+ }
+
+-----------------------------------------------------------------
+--
+-- processDeps
+--
+-----------------------------------------------------------------
+
+processDeps :: DynFlags
+ -> HscEnv
+ -> UniqSet ModuleName -- ^ Excludes
+ -> [DepSink]
+ -> SCC ModuleGraphNode
+ -> IO ()
+-- Write suitable dependencies to handle
+-- Always:
+-- this.o : this.hs
+--
+-- If the dependency is on something other than a .hi file:
+-- this.o this.p_o ... : dep
+-- otherwise
+-- this.o ... : dep.hi
+-- this.p_o ... : dep.p_hi
+-- ...
+-- (where .o is $osuf, and the other suffixes come from
+-- the cmdline -s options).
+--
+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
+
+processDeps _ hsc_env _ _ (CyclicSCC nodes)
+ = -- There shouldn't be any cycles; report them
+ throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes
+
+processDeps _ hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node))
+ = -- There shouldn't be any backpack instantiations; report them as well
+ throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $
+ mkPlainErrorMsgEnvelope noSrcSpan $
+ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
+
+processDeps _dflags _ _ _ (AcyclicSCC (LinkNode {})) = return ()
+processDeps _dflags _ _ _ (AcyclicSCC (UnitNode {})) = return ()
+processDeps _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))
+ -- No dependencies needed for fixed modules (already compiled)
+ = return ()
+
+processDeps dflags hsc_env excl_mods sinks (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do
+ pp <- preprocessor
+ let
+ dep_node = mkDepNode pp
+ find_deps imps = do
+ cpp_deps <- find_cpp_deps
+ import_deps <- find_import_deps imps
+ pure $ map Right cpp_deps ++ import_deps
+ (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)
+
+ if null missing_dep_errs
+ then do
+ traverse_ (\ sink -> ds_writeDependency sink dep_node deps) sinks
+ else do
+ let sec = initSourceErrorContext (hsc_dflags hsc_env)
+ throwErrors sec (mkMessages (listToBag missing_dep_errs))
+ where
+ src_file = msHsFileOsPath node
+ mkDepNode preproc =
+ DepNode
+ { dn_mod = GWIB (ms_mod node) (isBootSummary node)
+ , dn_src = src_file
+ , dn_obj = msObjFileOsPath node
+ , dn_hi = msHiFileOsPath node
+ , dn_preprocessing = preproc
+ }
+
+ preprocessor :: IO PreprocessingNode
+ preprocessor
+ | Just src <- ml_hs_file (ms_location node)
+ = runPipeline (hsc_hooks hsc_env) $ do
+ let
+ (_, suffix) = FilePath.splitExtension src
+ lit | Unlit _ <- startPhase suffix = True
+ | otherwise = False
+ pipe_env = mkPipeEnv StopPreprocess src Nothing NoOutputFile
+ unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env src) else pure src
+ (dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (ms_hspp_opts node) unlit_fn)
+ let pp = pgm_F dflags1
+ pure PreprocessingNode
+ { pn_preprocessor = if null pp then global_preprocessor else Just pp
+ , pn_options = opts
+ }
+ | otherwise
+ = pure PreprocessingNode
+ { pn_preprocessor = global_preprocessor
+ , pn_options = []
+ }
+
+ global_preprocessor :: Maybe String
+ global_preprocessor
+ | let pp = pgm_F dflags
+ , not (null pp)
+ = Just pp
+ | otherwise
+ = Nothing
+
+ -- Emit a dependency for each CPP import
+ -- CPP deps are discovered in the module parsing phase by parsing
+ -- comment lines left by the preprocessor.
+ -- Note that GHC.parseModule may throw an exception if the module
+ -- fails to parse, which may not be desirable (see #16616).
+ find_cpp_deps :: IO [Dep]
+ find_cpp_deps =
+ if depIncludeCppDeps dflags
+ then do
+ session <- Session <$> newIORef hsc_env
+ parsedMod <- reflectGhc (GHC.parseModule node) session
+ pure (DepCpp . unsafeEncodeUtf <$> GHC.pm_extra_src_files parsedMod)
+ else
+ pure []
+
+ -- Emit a dependency for each import
+ find_import_deps :: [UnresolvedImport PkgQual] -> IO [Either (MsgEnvelope GhcMessage) Dep]
+ find_import_deps idecls =
+ sequence
+ [ findDependency hsc_env decl
+ | decl <- idecls
+ , let L _loc mod = ui_mod_name decl
+ , not $ mod `UniqSet.elementOfUniqSet` excl_mods
+ ]
+
+findDependency :: HscEnv
+ -> UnresolvedImport PkgQual -- The import to find
+ -> IO (Either (MsgEnvelope GhcMessage) Dep) -- Interface file
+findDependency hsc_env imp = do
+ -- Find the module; this will be fast because
+ -- we've done it once during downsweep.
+ r <- resolveImport hsc_env imp
+ case r of
+ Found loc dep_mod ->
+ pure $ Right
+ DepHi
+ { dep_mod = dep_mod
+ , dep_path = ml_hi_file_ospath loc
+ , dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod)
+ , dep_local = isJust (ml_hs_file loc)
+ , dep_boot = is_boot
+ , dep_level = ui_level imp
+ }
+
+ fail ->
+ return $
+ Left $
+ mkPlainErrorMsgEnvelope srcloc $
+ GhcDriverMessage $ DriverInterfaceError $
+ (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot))
+ where
+ L srcloc mod_name = ui_mod_name imp
+ is_boot = ui_boot imp
+
-----------------------------------------------------------------
--
-- beginMkDependHs
@@ -136,6 +373,18 @@ doMkDependModuleGraph dflags module_graph = do
--
-----------------------------------------------------------------
+initFileDepWriter :: Logger -> OsPath -> TmpFs -> DynFlags -> IO DependencyWriter
+initFileDepWriter logger root tmpfs dflags = do
+ files <- beginMkDependHS logger tmpfs dflags
+ pure DependencyWriter
+ { dw_beginWriter = do
+ pure $ DepSink $ \ node deps -> do
+ writeDependencies (depIncludePkgDeps dflags) root (mkd_tmp_hdl files) suffixes node deps
+ , dw_endWriter = endMkDependHS logger files
+ }
+ where
+ suffixes = map unsafeEncodeUtf (depSuffixes dflags)
+
data MkDepFiles
= MkDep { mkd_make_file :: FilePath, -- Name of the makefile
mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
@@ -151,7 +400,7 @@ beginMkDependHS logger tmpfs dflags = do
-- open the makefile
let makefile = depMakefile dflags
- exists <- doesFileExist makefile
+ exists <- Directory.doesFileExist makefile
mb_make_hdl <-
if not exists
then return Nothing
@@ -188,141 +437,53 @@ beginMkDependHS logger tmpfs dflags = do
return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
+writeDependencies ::
+ Bool ->
+ OsPath ->
+ Handle ->
+ [OsString] ->
+ -- ^ Suffixes
+ DepNode ->
+ [Dep] ->
+ IO ()
+writeDependencies include_pkgs root hdl suffixes node deps =
+ traverse_ write tasks
+ where
+ tasks = source_dep : boot_dep ++ concatMap import_dep deps
+
+ -- Emit std dependency of the object(s) on the source file
+ -- Something like A.o : A.hs
+ source_dep = (obj_files, dn_src)
+
+ -- add dependency between objects and their corresponding .hi-boot
+ -- files if the module has a corresponding .hs-boot file (#14482)
+ boot_dep = case gwib_isBoot dn_mod of
+ IsBoot -> [([obj], hi) | (obj, hi) <- zip (suffixed (removeBootSuffix dn_obj)) (suffixed dn_hi)]
+ NotBoot -> []
+
+ -- Add one dependency for each suffix;
+ -- e.g. A.o : B.hi
+ -- A.x_o : B.x_hi
+ import_dep = \case
+ DepHi {dep_path, dep_unit}
+ | isNothing dep_unit || include_pkgs
+ -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed dep_path)]
------------------------------------------------------------------
---
--- processDeps
---
------------------------------------------------------------------
-
-processDeps :: DynFlags
- -> HscEnv
- -> [ModuleName]
- -> FilePath
- -> Handle -- Write dependencies to here
- -> SCC ModuleGraphNode
- -> IO ()
--- Write suitable dependencies to handle
--- Always:
--- this.o : this.hs
---
--- If the dependency is on something other than a .hi file:
--- this.o this.p_o ... : dep
--- otherwise
--- this.o ... : dep.hi
--- this.p_o ... : dep.p_hi
--- ...
--- (where .o is $osuf, and the other suffixes come from
--- the cmdline -s options).
---
--- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
-
-processDeps _ hsc_env _ _ _ (CyclicSCC nodes)
- = -- There shouldn't be any cycles; report them
- throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes
-
-processDeps _ hsc_env _ _ _ (AcyclicSCC (InstantiationNode _uid node))
- = -- There shouldn't be any backpack instantiations; report them as well
- throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $
- mkPlainErrorMsgEnvelope noSrcSpan $
- GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
-
-processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
-processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return ()
-processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))
- -- No dependencies needed for fixed modules (already compiled)
- = return ()
-processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node)))
- = do { let extra_suffixes = depSuffixes dflags
- include_pkg_deps = depIncludePkgDeps dflags
- src_file = msHsFilePath node
- obj_file = msObjFilePath node
- obj_files = insertSuffixes obj_file extra_suffixes
-
-
-
- -- Emit std dependency of the object(s) on the source file
- -- Something like A.o : A.hs
- ; writeDependency root hdl obj_files src_file
-
- -- add dependency between objects and their corresponding .hi-boot
- -- files if the module has a corresponding .hs-boot file (#14482)
- ; when (isBootSummary node == IsBoot) $ do
- let hi_boot = msHiFilePath node
- let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node)
- forM_ extra_suffixes $ \suff -> do
- let way_obj = insertSuffixes obj [suff]
- let way_hi_boot = insertSuffixes hi_boot [suff]
- mapM_ (writeDependency root hdl way_obj) way_hi_boot
-
- -- Emit a dependency for each CPP import
- ; when (depIncludeCppDeps dflags) $ do
- -- CPP deps are discovered in the module parsing phase by parsing
- -- comment lines left by the preprocessor.
- -- Note that GHC.parseModule may throw an exception if the module
- -- fails to parse, which may not be desirable (see #16616).
- { session <- Session <$> newIORef hsc_env
- ; parsedMod <- reflectGhc (GHC.parseModule node) session
- ; mapM_ (writeDependency root hdl obj_files)
- (GHC.pm_extra_src_files parsedMod)
- }
-
- -- Emit a dependency for each import
-
- ; let find_deps imps = sequence
- [ findDependency hsc_env imp include_pkg_deps
- | imp <- imps
- , unLoc (ui_mod_name imp) `notElem` excl_mods
- ]
-
- do_imp hi_file = do
- let hi_files = insertSuffixes hi_file extra_suffixes
- write_dep (obj,hi) = writeDependency root hdl [obj] hi
+ | otherwise
+ -> []
- -- Add one dependency for each suffix;
- -- e.g. A.o : B.hi
- -- A.x_o : B.x_hi
- mapM_ write_dep (obj_files `zip` hi_files)
+ DepCpp {dep_path} -> [(obj_files, dep_path)]
- ; (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)
+ write (from, to) = writeDependency root hdl from to
- ; if null missing_dep_errs
- then mapM_ (mapM_ do_imp) deps
- else do
- let sec = initSourceErrorContext (hsc_dflags hsc_env)
- throwErrors sec (mkMessages (listToBag missing_dep_errs))
- }
+ obj_files = suffixed dn_obj
-findDependency :: HscEnv
- -> UnresolvedImport PkgQual -- The import to find
- -> Bool -- Record dependency on package modules
- -> IO (Either (MsgEnvelope GhcMessage) (Maybe FilePath)) -- Interface file
-findDependency hsc_env imp include_pkg_deps = do
- -- Find the module; this will be fast because
- -- we've done it once during downsweep.
- r <- resolveImport hsc_env imp
- case r of
- Found loc _
- -- Home package: just depend on the .hi or hi-boot file
- | isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Right (Just (ml_hi_file loc)))
+ suffixed f = insertSuffixes f suffixes
- -- Not in this package: we don't need a dependency
- | otherwise
- -> return (Right Nothing)
-
- fail ->
- return $
- Left $
- mkPlainErrorMsgEnvelope srcloc $
- GhcDriverMessage $ DriverInterfaceError $
- (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot))
- where
- L srcloc mod_name = ui_mod_name imp
- is_boot = ui_boot imp
+ DepNode {dn_src, dn_obj, dn_hi, dn_mod} = node
-----------------------------
-writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
+writeDependency :: OsPath -> Handle -> [OsPath] -> OsPath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
-- t1 t2 : dep
writeDependency root hdl targets dep
@@ -330,33 +491,30 @@ writeDependency root hdl targets dep
-- c:/foo/...
-- on Windows as make gets confused by the :
-- Making relative deps avoids some instances of this.
- dep' = makeRelative root dep
- forOutput = escapeSpaces . reslash Forwards . normalise
+ dep' = OsPath.makeRelative root dep
+ forOutput = escapeSpaces . reslash Forwards . unsafeDecodeUtf . OsPath.normalise
output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
hPutStrLn hdl output
-----------------------------
insertSuffixes
- :: FilePath -- Original filename; e.g. "foo.o"
- -> [String] -- Suffix prefixes e.g. ["x_", "y_"]
- -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
+ :: OsPath -- Original filename; e.g. "foo.o"
+ -> [OsString] -- Suffix prefixes e.g. ["x_", "y_"]
+ -> [OsPath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
-- Note that the extra bit gets inserted *before* the old suffix
-- We assume the old suffix contains no dots, so we know where to
-- split it
insertSuffixes file_name extras
- = [ basename <.> (extra ++ suffix) | extra <- extras ]
+ = [ basename <.> (extra Monoid.<> suffix) | extra <- extras ]
where
- (basename, suffix) = case splitExtension file_name of
+ (basename, suffix) = case OsPath.splitExtension file_name of
-- Drop the "." from the extension
- (b, s) -> (b, drop 1 s)
+ (b, s) -> (b, OsString.drop 1 s)
-----------------------------------------------------------------
---
--- endMkDependHs
--- Complete the makefile, close the tmp file etc
---
------------------------------------------------------------------
+-- endMkDependHs
+-- Complete the makefile, close the tmp file etc
endMkDependHS :: Logger -> MkDepFiles -> IO ()
@@ -385,6 +543,277 @@ endMkDependHS logger
showPass logger "Installing new makefile"
SysTools.copyFile tmp_file makefile
+-----------------------------------------------------------------
+--
+-- JSON MkDepends output
+--
+-----------------------------------------------------------------
+
+initJsonDepWriter :: FilePath -> DynFlags -> IO DependencyWriter
+initJsonDepWriter output dflags = do
+ json_var <- mkJsonOutput output initDepJson
+ pure DependencyWriter
+ { dw_beginWriter =
+ pure $ DepSink $ \ node deps ->
+ updateJson json_var (updateDepJson (depIncludePkgDeps dflags) node deps)
+ , dw_endWriter =
+ writeJsonOutput json_var
+ }
+
+--------------------------------------------------------------------------------
+-- Output interface for json dumps
+
+-- | Resources for a json dump option, used in "GHC.Driver.MakeFile".
+-- The flag @-dep-json@ add an additional output target for dependency
+-- diagnostics.
+data JsonOutput a =
+ JsonOutput {
+ -- | This ref is updated in @processDeps@ incrementally, using a
+ -- flag-specific type.
+ json_ref :: IORef a,
+
+ -- | The output file path specified as argument to the flag.
+ json_path :: FilePath
+ }
+
+-- | TODO: @fendor
+mkJsonOutput ::
+ FilePath ->
+ IO (IORef a) ->
+ IO (JsonOutput a)
+mkJsonOutput json_path mk_ref = do
+ json_ref <- mk_ref
+ pure JsonOutput {json_ref, json_path}
+
+-- | Update the dump data in 'json_ref' if the output target is present.
+updateJson :: JsonOutput a -> (a -> a) -> IO ()
+updateJson JsonOutput {json_ref} f = modifyIORef' json_ref f
+
+-- | Write a json object to the flag-dependent file if the output target is
+-- present.
+writeJsonOutput ::
+ ToJson a =>
+ JsonOutput a ->
+ IO ()
+writeJsonOutput JsonOutput {json_ref, json_path} = do
+ payload <- readIORef json_ref
+ writeJsonFile payload json_path
+
+--------------------------------------------------------------------------------
+-- Output helpers
+
+writeJsonFile :: ToJson a => a -> FilePath -> IO ()
+writeJsonFile doc p = do
+ withAtomicRename p
+ $ \tmp -> writeFile tmp $ showSDocUnsafe $ renderJSON $ json doc
+
+--------------------------------------------------------------------------------
+-- Payload for -dep-json
+
+newtype DPackageId = DPackageId PackageId
+ deriving newtype (Eq)
+
+instance Ord DPackageId where
+ DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2
+
+data ModuleNodeDeps = ModuleNodeDeps
+ { source :: OsPath
+ , imports :: ImportDeps
+ , cpp :: Set.Set OsPath
+ , options :: [String]
+ , preprocessor :: Maybe FilePath
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically ModuleNodeDeps)
+
+addImport :: ImportDep -> ModuleNodeDeps -> ModuleNodeDeps
+addImport import_dep mod_node_deps =
+ mod_node_deps
+ { imports = ImportDeps $ Map.insertWith Set.union uid (Set.singleton import_dep) (getImports $ imports mod_node_deps)
+ }
+ where
+ uid = toUnitId $ moduleUnit $ imp_mod import_dep
+
+addCpp :: OsPath -> ModuleNodeDeps -> ModuleNodeDeps
+addCpp p mod_node_deps =
+ mod_node_deps
+ { cpp = Set.insert p (cpp mod_node_deps)
+ }
+
+newtype ImportDeps = ImportDeps { getImports :: Map.Map UnitId (Set.Set ImportDep) }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically ImportDeps)
+
+data ImportDep = ImportDep
+ { imp_mod :: Module
+ , imp_level :: ImportLevel
+ , imp_isBoot :: IsBootInterface
+ } deriving (Eq, Ord)
+
+mkImportDep :: Module -> ImportLevel -> IsBootInterface -> ImportDep
+mkImportDep modl level isBoot = ImportDep
+ { imp_mod = modl
+ , imp_level = level
+ , imp_isBoot = isBoot
+ }
+
+data HomeUnitDeps = HomeUnitDeps
+ { homeModules :: Map.Map ModuleWithIsBoot ModuleNodeDeps
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically HomeUnitDeps)
+
+data ExtUnitDep = ExtUnitDep
+ { extUnitId :: UnitId
+ -- ^ The 'UnitId' of a unit. This is assumed to be globally unique.
+ , extUnitName :: String
+ , extUnitPackageId :: DPackageId
+ } deriving (Eq, Ord)
+
+data DepJson = DepJson
+ { homeUnitDeps :: Map.Map UnitId HomeUnitDeps
+ , externalDeps :: Set.Set ExtUnitDep
+ }
+
+instance ToJson DepJson where
+ json (DepJson homeUnits extDeps) =
+ JSObject $
+ [ homeUnit huid hud
+ | (huid, hud) <- Map.toList homeUnits
+ ] ++
+ [ mkExtDepObj dep
+ | dep <- Set.toList extDeps
+ ]
+ where
+ homeUnit uid hud =
+ ( unitIdString uid
+ , JSObject
+ [
+ ( "modules"
+ , JSObject
+ [ (homeUnitModuleKey modl, homeUnitModule deps)
+ | (modl, deps) <- Map.toList $ homeModules hud
+ ]
+ )
+ ]
+ )
+
+ homeUnitModuleKey :: ModuleWithIsBoot -> String
+ homeUnitModuleKey t = moduleKey (gwib_mod t) (gwib_isBoot t)
+
+ moduleKey :: Module -> IsBootInterface -> String
+ moduleKey t b = moduleNameString (moduleName t) ++ case b of
+ IsBoot -> "[boot]"
+ NotBoot -> ""
+
+ homeUnitModule :: ModuleNodeDeps -> JsonDoc
+ homeUnitModule ModuleNodeDeps {source, imports, cpp, options, preprocessor} =
+ JSObject
+ [ ("source", JSString . showOsPath $ normalise source)
+ , ("imports", importsObj imports)
+ , ("includes", strArray cpp showOsPath)
+ , ("options", JSArray $ map JSString options)
+ , ("preprocessor", maybe JSNull JSString preprocessor)
+ ]
+
+ importsObj :: ImportDeps -> JsonDoc
+ importsObj importDeps = JSArray $ map importObj (Map.toList $ getImports importDeps)
+
+ importObj :: (UnitId, Set.Set ImportDep) -> JsonDoc
+ importObj (uid, importSet) =
+ JSObject
+ [ (unitIdString uid, array importSet importDepObj )
+ ]
+
+ importDepObj :: ImportDep -> JsonDoc
+ importDepObj ImportDep {imp_mod, imp_level, imp_isBoot}
+ | NormalLevel <- imp_level = JSString (moduleKey imp_mod imp_isBoot)
+ | otherwise = JSObject
+ [ ("module", JSString (moduleKey imp_mod imp_isBoot))
+ , ("level" , importLevel imp_level)
+ ]
+
+ importLevel :: ImportLevel -> JsonDoc
+ importLevel lvl =
+ JSString $ case lvl of
+ NormalLevel -> "normal"
+ SpliceLevel -> "splice"
+ QuoteLevel -> "quote"
+
+ mkExtDepObj :: ExtUnitDep -> (String, JsonDoc)
+ mkExtDepObj ExtUnitDep{..} =
+ ( unitIdString extUnitId
+ , JSObject
+ [ ("package-name", JSString extUnitName)
+ , ("package-id", JSString $ showPackageId extUnitPackageId)
+ ]
+ )
+
+ array values render = JSArray (fmap render (Set.toList values))
+ strArray values render = JSArray (fmap (JSString . render) (Set.toList values))
+
+ showOsPath = unsafeDecodeUtf
+ showPackageId (DPackageId (PackageId pid)) = unpackFS pid
+
+initDepJson :: IO (IORef DepJson)
+initDepJson = newIORef $ DepJson Map.empty Set.empty
+
+insertDepJson :: ModuleWithIsBoot -> ModuleNodeDeps -> Set.Set ExtUnitDep -> DepJson -> DepJson
+insertDepJson target modNode extUnits (DepJson m0 e0) =
+ DepJson
+ { homeUnitDeps =
+ Map.insertWith
+ (Semigroup.<>)
+ modUnitId
+ (HomeUnitDeps $ Map.singleton target modNode)
+ m0
+ , externalDeps =
+ Set.union e0 extUnits
+ }
+ where
+ modUnitId = toUnitId $ moduleUnit $ gwib_mod target
+
+updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
+updateDepJson include_pkgs DepNode {..} deps =
+ insertDepJson dn_mod payload externalDeps
+ where
+ (externalDeps, payload) = foldl' go (Set.empty, initial_node_data) deps
+
+ initial_node_data =
+ ModuleNodeDeps
+ { source = dn_src
+ , preprocessor = pn_preprocessor dn_preprocessing
+ , options = pn_options dn_preprocessing
+ , cpp = Set.empty
+ , imports = ImportDeps Map.empty
+ }
+
+ go (extDeps, node_data) = \ case
+ DepHi {dep_mod, dep_local, dep_unit, dep_boot, dep_level}
+ | dep_local
+ -> (extDeps, addImport (mkImportDep dep_mod dep_level dep_boot) node_data)
+
+ | include_pkgs
+ , Just unit <- dep_unit
+ , let PackageName nameFS = unitPackageName unit
+ name = unpackFS nameFS
+ withLibName (PackageName c) = name ++ ":" ++ unpackFS c
+ lname = maybe name withLibName (unitComponentName unit)
+ newExtDep = ExtUnitDep
+ { extUnitId = unitId unit
+ , extUnitName = lname
+ , extUnitPackageId = DPackageId $ unitPackageId unit
+ }
+ ->
+ ( Set.insert newExtDep extDeps
+ , addImport (mkImportDep dep_mod dep_level dep_boot) node_data
+ )
+
+ | otherwise
+ -> (extDeps, node_data)
+
+ DepCpp {dep_path} ->
+ (extDeps, addCpp dep_path node_data)
-----------------------------------------------------------------
-- Module cycles
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -820,13 +820,13 @@ preprocessPipeline pipe_env hsc_env input_fn = do
use (T_Unlit pipe_env hsc_env input_fn)
- (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
+ (dflags1, _, p_warns1, warns1) <- use (fileArgsPhase hsc_env unlit_fn)
let hsc_env1 = hscSetFlags dflags1 hsc_env
(cpp_fn, hsc_env2)
<- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do
cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)
- (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)
+ (dflags2, _, _, _) <- use (fileArgsPhase hsc_env1 cpp_fn)
let hsc_env2 = hscSetFlags dflags2 hsc_env1
return (cpp_fn, hsc_env2)
@@ -841,7 +841,8 @@ preprocessPipeline pipe_env hsc_env input_fn = do
then return (dflags1, p_warns1, warns1)
else do
-- Reparse with original hsc_env so that we don't get duplicated options
- use (T_FileArgs hsc_env pp_fn)
+ (dflagsPP, _, p_warns3, warns3) <- use (fileArgsPhase hsc_env pp_fn)
+ pure (dflagsPP, p_warns3, warns3)
let print_config = initPrintConfig dflags3
liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
@@ -865,6 +866,9 @@ preprocessPipeline pipe_env hsc_env input_fn = do
runAfter phase def
$ phaseIfFlag hsc_env flag def action
+ fileArgsPhase env fn =
+ T_FileArgs (hsc_logger env) (hsc_dflags env) fn
+
-- | The complete compilation pipeline, from start to finish
fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables)
fullPipeline pipe_env hsc_env pp_fn src_flavour = do
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -104,7 +104,7 @@ runPhase :: TPhase out -> IO out
runPhase (T_Unlit pipe_env hsc_env inp_path) = do
out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing
runUnlitPhase hsc_env inp_path out_path
-runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path
+runPhase (T_FileArgs logger dflags inp_path) = getFileArgsNoHsc logger dflags inp_path
runPhase (T_Cpp pipe_env hsc_env inp_path) = do
out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing
runCppPhase hsc_env inp_path out_path
@@ -620,17 +620,21 @@ runUnlitPhase hsc_env input_fn output_fn = do
return output_fn
-getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage))
+getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, [String], Messages PsMessage, Messages DriverMessage))
getFileArgs hsc_env input_fn = do
let dflags0 = hsc_dflags hsc_env
logger = hsc_logger hsc_env
- parser_opts = initParserOpts dflags0
+ getFileArgsNoHsc logger dflags0 input_fn
+
+getFileArgsNoHsc :: Logger -> DynFlags -> FilePath -> IO ((DynFlags, [String], Messages PsMessage, Messages DriverMessage))
+getFileArgsNoHsc logger dflags0 input_fn = do
+ let parser_opts = initParserOpts dflags0
sec = initSourceErrorContext dflags0
(warns0, src_opts) <- getOptionsFromFile parser_opts sec (supportedLanguagePragmas dflags0) input_fn
(dflags1, unhandled_flags, warns)
<- parseDynamicFilePragma logger dflags0 src_opts
checkProcessArgsResult dflags0 unhandled_flags
- return (dflags1, warns0, warns)
+ return (dflags1, map unLoc src_opts, warns0, warns)
runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
runCppPhase hsc_env input_fn output_fn = do
=====================================
compiler/GHC/Driver/Pipeline/Phases.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Driver.Errors.Types
import GHC.Fingerprint.Type
import GHC.Unit.Module.Location ( ModLocation )
import GHC.Unit.Module.ModIface
+import GHC.Utils.Logger
import GHC.Driver.Phases
import Language.Haskell.Syntax.Module.Name ( ModuleName )
@@ -25,7 +26,7 @@ import GHC.Unit.Home.ModInfo
-- phase if the inputs have been modified.
data TPhase res where
T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
- T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage)
+ T_FileArgs :: Logger -> DynFlags -> FilePath -> TPhase ((DynFlags, [String], Messages PsMessage, Messages DriverMessage))
T_Cpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_HsPp :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath
T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -791,6 +791,12 @@ addOptCmmP f = alterToolSettings $ \s -> s
setDepMakefile :: FilePath -> DynFlags -> DynFlags
setDepMakefile f d = d { depMakefile = f }
+setDepJson :: FilePath -> DynFlags -> DynFlags
+setDepJson f d = d { depJson = Just f }
+
+unsetDepJson :: DynFlags -> DynFlags
+unsetDepJson d = d { depJson = Nothing }
+
setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags
setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }
@@ -1261,6 +1267,8 @@ dynamic_flags_deps = [
-------- ghc -M -----------------------------------------------------
, make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix)
, make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile)
+ , make_ord_flag defGhcFlag "dep-json" (hasArg setDepJson)
+ , make_ord_flag defGhcFlag "no-dep-json" (noArg unsetDepJson)
, make_ord_flag defGhcFlag "include-cpp-deps"
(noArg (setDepIncludeCppDeps True))
, make_ord_flag defGhcFlag "include-pkg-deps"
=====================================
docs/users_guide/separate_compilation.rst
=====================================
@@ -1503,6 +1503,23 @@ generation are:
``.depend`` and then ``include`` the file ``.depend`` into
``Makefile``.
+.. ghc-flag:: -dep-json ⟨file⟩
+ :shortdesc: Also emit ⟨file⟩ as a JSON file containing dependencies
+ :type: dynamic
+ :reverse: -no-dep-json
+ :category: redirect-output
+
+ In addition to the makefile, also emit ⟨file⟩ as a JSON file
+ containing the same dependencies info, so it can be parsed by
+ external build systems. The JSON file contains a single object,
+ mapping each target to a list of dependencies.
+ In addition to the makefile, each module's payload will contain the
+ values of ``OPTIONS`` and ``LANGUAGE`` pragmas of the source
+ file, so it can be parsed by external build systems. Each ``LANGUAGE``
+ pragma is represented as an option as well, e.g.
+ ``{-# LANGUAGE TemplateHaskell #-}`` is represented as
+ ``"-XTemplateHaskell"``.
+
.. ghc-flag:: -dep-suffix ⟨suffix⟩
:shortdesc: Make dependencies that declare that files with suffix
``.⟨suf⟩⟨osuf⟩`` depend on interface files with suffix ``.⟨suf⟩hi``
=====================================
testsuite/driver/testlib.py
=====================================
@@ -20,6 +20,7 @@ from pathlib import Path, PurePath
import collections
import collections.abc
import subprocess
+import json
from testglobals import config, ghc_env, default_testopts, brokens, t, \
TestRun, TestResult, TestOptions, PerfMetric
@@ -3265,6 +3266,34 @@ def normalise_asm( s: str ) -> str:
out.append(ins[0])
return '\n'.join(out)
+def normalise_dep_json(s: str) -> str:
+ """
+ Normalise the json output of `ghc -M -dep-json output.json`
+ """
+
+ def normalise_includes(j):
+ # Only normalise proper json objects.
+ # Strings might be parsed as json strings, but we that's not what we are looking for
+ if not isinstance(j, dict):
+ return j
+ for unit in j.values():
+ for module in unit.get("modules", {}).values():
+ rewritten = [
+ "<absolute-path>/" + p.rsplit("/", 1)[-1] if p.startswith("/") else p
+ for p in module["includes"]
+ ]
+ # we sort to make sure this never
+ module["includes"] = sorted(rewritten)
+ return j
+
+ output = ""
+ try:
+ normalised_dep_json = normalise_includes(json.loads(s))
+ output = json.dumps(normalised_dep_json, indent=2, sort_keys=True, ensure_ascii=False)
+ except json.JSONDecodeError:
+ output = line
+ return output
+
def safe_print(s: str) -> None:
s2 = s.encode(sys.stdout.encoding, errors='replace').decode(sys.stdout.encoding)
print(s2)
=====================================
testsuite/tests/driver/T24384/A.hs
=====================================
@@ -0,0 +1,7 @@
+{-# language Strict #-}
+{-# language CPP #-}
+{-# options_ghc -fexpose-all-unfoldings #-}
+module A where
+
+#include "foo.h"
+import {-# source #-} C
=====================================
testsuite/tests/driver/T24384/C.hs
=====================================
@@ -0,0 +1,6 @@
+module C where
+
+import A
+import Data.Set
+
+data C = C
=====================================
testsuite/tests/driver/T24384/C.hs-boot
=====================================
@@ -0,0 +1,5 @@
+module C where
+
+import E
+
+data C
=====================================
testsuite/tests/driver/T24384/D.hs
=====================================
@@ -0,0 +1,4 @@
+module D where
+
+import B
+import C
=====================================
testsuite/tests/driver/T24384/E.hs
=====================================
@@ -0,0 +1,14 @@
+module E where
+
+import Language.Haskell.TH.Syntax
+import Dep
+import DepPublic
+
+e :: Q Exp
+e = lift (5 :: Integer)
+
+edep :: ()
+edep = dep
+
+edepPub :: ()
+edepPub = depPub
=====================================
testsuite/tests/driver/T24384/Makefile
=====================================
@@ -0,0 +1,56 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+
+PKGCONF_LOCAL=./db.package.conf
+GHC_PKG_LOCAL='$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_LOCAL)
+
+T24384_prep:
+ rm -r $(PKGCONF_LOCAL) || true
+ $(GHC_PKG_LOCAL) init $(PKGCONF_LOCAL) 2>&1 >/dev/null
+
+ cd dep-internal && \
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \
+ -v0 -fno-code -fwrite-interface -hidir outdir -this-unit-id dep-internal-1-XXX \
+ -package base \
+ -i. DepInternal
+ $(GHC_PKG_LOCAL) register --force dep-internal/dep-internal.pkg 2>&1 >/dev/null
+
+ cd dep-public && \
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \
+ -v0 -fno-code -fwrite-interface -hidir outdir -this-unit-id dep-public-1-XXX \
+ -package base \
+ -i. DepPublic
+ $(GHC_PKG_LOCAL) register --force dep-public/dep-public.pkg 2>&1 >/dev/null
+
+ cd dep && \
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \
+ -v0 -fno-code -fwrite-interface -hidir outdir -this-unit-id dep-1-XXX \
+ -package-db ../$(PKGCONF_LOCAL) -package-id dep-internal-1-XXX \
+ -i. Dep
+ $(GHC_PKG_LOCAL) register --force dep/dep.pkg 2>&1 >/dev/null
+
+T24384a: T24384_prep
+ '$(TEST_HC)' -M -dep-makefile T24384a.Makefile -include-pkg-deps -include-cpp-deps \
+ -hide-all-packages -package base -package containers -package template-haskell \
+ -package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \
+ A.hs lib/B.hs C.hs D.hs E.hs
+
+ cat T24384a.Makefile
+
+T24384b: T24384_prep
+ '$(TEST_HC)' -M -dep-json dep.json -include-pkg-deps -include-cpp-deps \
+ -hide-all-packages -package base -package containers -package template-haskell \
+ -package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \
+ A.hs lib/B.hs C.hs D.hs E.hs
+
+ cat dep.json
+
+T24384c: T24384_prep
+ '$(TEST_HC)' -M -dep-json dep.json \
+ -hide-all-packages -package base -package containers -package template-haskell \
+ -package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \
+ A.hs lib/B.hs C.hs D.hs E.hs
+
+ cat dep.json
=====================================
testsuite/tests/driver/T24384/T24384a.stdout
=====================================
@@ -0,0 +1,39 @@
+# DO NOT DELETE: Beginning of Haskell dependencies
+E.o : E.hs
+E.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+E.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+E.o : dep-public/outdir/DepPublic.hi
+E.o : dep/outdir/Dep.hi
+E.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/template-haskell-2.25.0.0-inplace/Language/Haskell/TH/Syntax.hi
+C.o-boot : C.hs-boot
+C.o : C.hi-boot
+C.o-boot : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+C.o-boot : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+C.o-boot : E.hi
+A.o : A.hs
+A.o : foo.h
+A.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/rts-1.0.3/include/ghcversion.h
+A.o : /usr/include/stdc-predef.h
+A.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+A.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+A.o : C.hi-boot
+C.o : C.hs
+C.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+C.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+C.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/containers-0.8-inplace/Data/Set.hi
+C.o : A.hi
+lib/B.o-boot : lib/B.hs-boot
+lib/B.o : lib/B.hi-boot
+lib/B.o-boot : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+lib/B.o-boot : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+lib/B.o-boot : A.hi
+lib/B.o : lib/B.hs
+lib/B.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+lib/B.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+lib/B.o : A.hi
+D.o : D.hs
+D.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/Prelude.hi
+D.o : /home/hugin/Documents/haskell/ghc-homes/ghc-dep-json/_build/stage1/lib/../lib/x86_64-linux-ghc-10.1.20260917-inplace/base-4.23.0.0-inplace/GHC/Essentials.hi
+D.o : C.hi
+D.o : lib/B.hi
+# DO NOT DELETE: End of Haskell dependencies
=====================================
testsuite/tests/driver/T24384/T24384b.stdout
=====================================
@@ -0,0 +1,191 @@
+{
+ "base-<VERSION>-<HASH>": {
+ "package-id": "base-<VERSION>-<HASH>",
+ "package-name": "base"
+ },
+ "containers-<VERSION>-<HASH>": {
+ "package-id": "containers-<VERSION>-<HASH>",
+ "package-name": "containers"
+ },
+ "dep-1-XXX": {
+ "package-id": "dep-1",
+ "package-name": "dep"
+ },
+ "dep-public-1-XXX": {
+ "package-id": "dep-public-1",
+ "package-name": "dep-public"
+ },
+ "main": {
+ "modules": {
+ "A": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "C[boot]"
+ ]
+ }
+ ],
+ "includes": [
+ "<absolute-path>/ghcversion.h",
+ "<absolute-path>/stdc-predef.h",
+ "foo.h"
+ ],
+ "options": [
+ "-XStrict",
+ "-XCPP",
+ "-fexpose-all-unfoldings"
+ ],
+ "preprocessor": null,
+ "source": "A.hs"
+ },
+ "B": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs"
+ },
+ "B[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs-boot"
+ },
+ "C": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "containers-<VERSION>-<HASH>": [
+ "Data.Set"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs"
+ },
+ "C[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "E"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs-boot"
+ },
+ "D": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "B",
+ "C"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "D.hs"
+ },
+ "E": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "dep-1-XXX": [
+ "Dep"
+ ]
+ },
+ {
+ "dep-public-1-XXX": [
+ "DepPublic"
+ ]
+ },
+ {
+ "template-haskell-<VERSION>-<HASH>": [
+ "Language.Haskell.TH.Syntax"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "E.hs"
+ }
+ }
+ },
+ "template-haskell-<VERSION>-<HASH>": {
+ "package-id": "template-haskell-<VERSION>-<HASH>",
+ "package-name": "template-haskell"
+ }
+}
=====================================
testsuite/tests/driver/T24384/T24384b.stdout-mingw
=====================================
@@ -0,0 +1,191 @@
+{
+ "base-<VERSION>-<HASH>": {
+ "package-id": "base-<VERSION>-<HASH>",
+ "package-name": "base"
+ },
+ "containers-<VERSION>-<HASH>": {
+ "package-id": "containers-<VERSION>-<HASH>",
+ "package-name": "containers"
+ },
+ "dep-1-XXX": {
+ "package-id": "dep-1",
+ "package-name": "dep"
+ },
+ "dep-public-1-XXX": {
+ "package-id": "dep-public-1",
+ "package-name": "dep-public"
+ },
+ "main": {
+ "modules": {
+ "A": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "C[boot]"
+ ]
+ }
+ ],
+ "includes": [
+ "<absolute-path>/ghcversion.h",
+ "<absolute-path>/stdc-predef.h",
+ "foo.h"
+ ],
+ "options": [
+ "-XStrict",
+ "-XCPP",
+ "-fexpose-all-unfoldings"
+ ],
+ "preprocessor": null,
+ "source": "A.hs"
+ },
+ "B": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs"
+ },
+ "B[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs-boot"
+ },
+ "C": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "containers-<VERSION>-<HASH>": [
+ "Data.Set"
+ ]
+ },
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs"
+ },
+ "C[boot]": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "E"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs-boot"
+ },
+ "D": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "main": [
+ "B",
+ "C"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "D.hs"
+ },
+ "E": {
+ "imports": [
+ {
+ "base-<VERSION>-<HASH>": [
+ "GHC.Essentials",
+ "Prelude"
+ ]
+ },
+ {
+ "dep-1-XXX": [
+ "Dep"
+ ]
+ },
+ {
+ "dep-public-1-XXX": [
+ "DepPublic"
+ ]
+ },
+ {
+ "template-haskell-<VERSION>-<HASH>": [
+ "Language.Haskell.TH.Syntax"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "E.hs"
+ }
+ }
+ },
+ "template-haskell-<VERSION>-<HASH>": {
+ "package-id": "template-haskell-<VERSION>-<HASH>",
+ "package-name": "template-haskell"
+ }
+}
=====================================
testsuite/tests/driver/T24384/T24384c.stdout
=====================================
@@ -0,0 +1,104 @@
+{
+ "main": {
+ "modules": {
+ "A": {
+ "imports": [
+ {
+ "main": [
+ "C[boot]"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-XStrict",
+ "-XCPP",
+ "-fexpose-all-unfoldings"
+ ],
+ "preprocessor": null,
+ "source": "A.hs"
+ },
+ "B": {
+ "imports": [
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs"
+ },
+ "B[boot]": {
+ "imports": [
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "preprocessor": "./preproc.sh",
+ "source": "lib/B.hs-boot"
+ },
+ "C": {
+ "imports": [
+ {
+ "main": [
+ "A"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs"
+ },
+ "C[boot]": {
+ "imports": [
+ {
+ "main": [
+ "E"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "C.hs-boot"
+ },
+ "D": {
+ "imports": [
+ {
+ "main": [
+ "B",
+ "C"
+ ]
+ }
+ ],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "D.hs"
+ },
+ "E": {
+ "imports": [],
+ "includes": [],
+ "options": [],
+ "preprocessor": null,
+ "source": "E.hs"
+ }
+ }
+ }
+}
=====================================
testsuite/tests/driver/T24384/all.T
=====================================
@@ -0,0 +1,15 @@
+test_extras = extra_files(
+ ['A.hs', 'lib/', 'C.hs', 'C.hs-boot', 'D.hs', 'E.hs',
+ 'foo.h',
+ 'dep', 'dep-internal', 'dep-public',
+ 'preproc.sh'
+ ])
+
+normalisers = [ normalise_version('base', 'containers', 'template-haskell')
+ , normalise_slashes
+ , normalise_fun(normalise_dep_json)
+ ]
+
+test('T24384a', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep'), *normalisers ], makefile_test, [])
+test('T24384b', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep'), *normalisers ], makefile_test, [])
+test('T24384c', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep'), *normalisers ], makefile_test, [])
=====================================
testsuite/tests/driver/T24384/dep-internal/DepInternal.hs
=====================================
@@ -0,0 +1,3 @@
+module DepInternal where
+depInt :: ()
+depInt = ()
=====================================
testsuite/tests/driver/T24384/dep-internal/dep-internal.pkg
=====================================
@@ -0,0 +1,11 @@
+name: dep-internal
+version: 1
+id: dep-internal-1-XXX
+key: dep-internal-1-XXX
+visibility: public
+abi: inplace
+exposed-modules: DepInternal
+depends:
+import-dirs: ${pkgroot}/dep-internal/outdir
+library-dirs: ${pkgroot}/dep-internal/outdir
+include-dirs:
=====================================
testsuite/tests/driver/T24384/dep-public/DepPublic.hs
=====================================
@@ -0,0 +1,3 @@
+module DepPublic where
+depPub :: ()
+depPub = ()
=====================================
testsuite/tests/driver/T24384/dep-public/dep-public.pkg
=====================================
@@ -0,0 +1,11 @@
+name: dep-public
+version: 1
+id: dep-public-1-XXX
+key: dep-public-1-XXX
+visibility: public
+abi: inplace
+exposed-modules: DepPublic
+depends:
+import-dirs: ${pkgroot}/dep-public/outdir
+library-dirs: ${pkgroot}/dep-public/outdir
+include-dirs:
=====================================
testsuite/tests/driver/T24384/dep/Dep.hs
=====================================
@@ -0,0 +1,4 @@
+module Dep where
+import DepInternal
+dep :: ()
+dep = depInt
=====================================
testsuite/tests/driver/T24384/dep/dep.pkg
=====================================
@@ -0,0 +1,11 @@
+name: dep
+version: 1
+id: dep-1-XXX
+key: dep-1-XXX
+visibility: public
+abi: inplace
+exposed-modules: Dep
+depends: dep-internal-1-XXX
+import-dirs: ${pkgroot}/dep/outdir
+library-dirs: ${pkgroot}/dep/outdir
+include-dirs:
=====================================
testsuite/tests/driver/T24384/foo.h
=====================================
=====================================
testsuite/tests/driver/T24384/format_json.sh
=====================================
@@ -0,0 +1,35 @@
+#!/usr/bin/env bash
+set -euo pipefail
+
+# Packages whose ids are rewritten to <pkg>-<VERSION>-<HASH>
+pkgs='base|containers|template-haskell'
+
+usage() {
+ cat <<EOF
+Usage: $(basename "$0") FILE
+
+Format one of the test -dep-json output file with jq and normalise it:
+ - absolute paths in "includes" become <absolute-path>/<filename>,
+ and the "includes" lists are sorted
+ - ids of the packages ${packages[*]}
+ (e.g. base-4.23.0.0-inplace) become <pkg>-<VERSION>-<HASH>
+
+Writes the output to FILE
+EOF
+}
+
+case "${1:-}" in -h|--help) usage; exit 0 ;; esac
+[ $# -eq 1 ] || { usage >&2; exit 1; }
+
+# Escape regex metacharacters (and the / delimiter) for sed
+esc() { sed 's/[][\.*^$+?(){}|/]/\\&/g'; }
+
+json=$(jq --sort-keys '
+ (.. | objects | select(has("includes")) | .includes) |=
+ (map(if startswith("/") then "<absolute-path>/" + (split("/") | last) else . end) | sort)
+' "$1")
+
+tmp=$(mktemp "$1.XXXXXX")
+trap 'rm -f "$tmp"' EXIT
+sed -E "s/($pkgs)-[0-9.]+(-[0-9a-zA-Z+]+)?(-[0-9a-zA-Z]+)?/\\1-<VERSION>-<HASH>/g" <<<"$json" > "$tmp"
+mv "$tmp" "$1"
=====================================
testsuite/tests/driver/T24384/lib/B.hs
=====================================
@@ -0,0 +1,2 @@
+{-# options_ghc -F -pgmF ./preproc.sh #-}
+module B where
=====================================
testsuite/tests/driver/T24384/lib/B.hs-boot
=====================================
@@ -0,0 +1,2 @@
+{-# options_ghc -F -pgmF ./preproc.sh #-}
+module B where
=====================================
testsuite/tests/driver/T24384/preproc.sh
=====================================
@@ -0,0 +1,4 @@
+#!/usr/bin/env bash
+
+sed '/preproc/d' $2 > $3
+echo 'import A' >> $3
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/020bc06ba6ec9a573ad33376bccb3e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/020bc06ba6ec9a573ad33376bccb3e…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/27835] Prepend in-memory unit database for backpack
by Hannes Siebenhandl (＠fendor) 01 Oct '26
by Hannes Siebenhandl (＠fendor) 01 Oct '26
01 Oct '26
Hannes Siebenhandl pushed to branch wip/fendor/27835 at Glasgow Haskell Compiler / GHC
Commits:
5305cbc1 by Hannes Siebenhandl at 2026-10-01T14:42:15+02:00
Prepend in-memory unit database for backpack
The packageDbFlags are stored in reverse order. Thus, prepending will
ensure that the in-memory unit database is the last item on the unit
database stack.
Further, the in-memory unit database needs to be able to shadow units
from earlier unit databases in the unit database stack.
Moreover, a `-clear-package-db` would remove the in-memory database if
it weren't the last item on the stack.
Closes #27835
- - - - -
5 changed files:
- changelog.d/unit-index
- compiler/GHC/Driver/Backpack.hs
- + testsuite/tests/backpack/should_compile/T27835.bkp
- + testsuite/tests/backpack/should_compile/T27835.stderr
- testsuite/tests/backpack/should_compile/all.T
Changes:
=====================================
changelog.d/unit-index
=====================================
@@ -1,7 +1,7 @@
section: compiler
synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units
-issues: #27500 #26423 #27748
-mrs: !16115 !16598
+issues: #27500 #26423 #27748 #27835
+mrs: !16115 !16598 !16748
description: {
The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s.
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do
}
let uic = hscUIC hsc_env
liftIO $ cacheExternalUnitDatabase uic newdb
- -- added at the end because ordering matters
+ -- Ordering matters here! We prepend the new unit database, because 'packageDBFlags'
+ -- works like a stack, where what's on top takes precedence over what's below (same as right-to-left when given at the CLI).
+ -- The new db needs highest precedence to overwrite any other in-memory units that potentially occur in the dbs below it.
pure dflags
- { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
+ { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags
}
-- | Register a new virtual unit database containing a single unit
=====================================
testsuite/tests/backpack/should_compile/T27835.bkp
=====================================
@@ -0,0 +1,11 @@
+unit p where
+ module P where
+ p :: Int
+ p = 42
+
+unit q where
+ dependency p
+ module Q where
+ import P
+ q :: Int
+ q = p + 1
=====================================
testsuite/tests/backpack/should_compile/T27835.stderr
=====================================
@@ -0,0 +1,7 @@
+[1 of 2] Processing p
+ Instantiating p
+ [1 of 1] Compiling P ( p/P.hs, T27835.out/p/P.o )
+[2 of 2] Processing q
+ Instantiating q
+ [1 of 1] Including p
+ [1 of 1] Compiling Q ( q/Q.hs, T27835.out/q/Q.o )
=====================================
testsuite/tests/backpack/should_compile/all.T
=====================================
@@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, [''])
test('T13323', normal, backpack_compile, [''])
test('T20396', normal, backpack_compile, [''])
test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace'])
+test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5305cbc104bbb820badda5b9d2653f5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5305cbc104bbb820badda5b9d2653f5…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/fendor/27836] Fix #27836, normalise unit database path in ExternalUnitDatabases
by Hannes Siebenhandl (＠fendor) 01 Oct '26
by Hannes Siebenhandl (＠fendor) 01 Oct '26
01 Oct '26
Hannes Siebenhandl pushed to branch wip/fendor/27836 at Glasgow Haskell Compiler / GHC
Commits:
0f51b26f by Hannes Siebenhandl at 2026-10-01T14:40:20+02:00
Fix #27836, normalise unit database path in ExternalUnitDatabases
Add a regression test, proofing that all variations:
- local-unit-db/my-test.conf
- ./local-unit-db/my-test.conf
- ./local-unit-db/my-test.conf/
are parsed only once.
- - - - -
11 changed files:
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Unit/External/Database.hs
- + testsuite/tests/driver/T27836/A.hs
- + testsuite/tests/driver/T27836/B.hs
- + testsuite/tests/driver/T27836/C.hs
- + testsuite/tests/driver/T27836/Makefile
- + testsuite/tests/driver/T27836/T27836.stdout
- + testsuite/tests/driver/T27836/all.T
- + testsuite/tests/driver/T27836/unitA
- + testsuite/tests/driver/T27836/unitB
- + testsuite/tests/driver/T27836/unitC
Changes:
=====================================
compiler/GHC/Data/OsPath.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Data.OsPath
, (<.>)
, splitSearchPath
, isRelative
+ , normalise
, dropTrailingPathSeparator
, takeDirectory
, isSuffixOf
=====================================
compiler/GHC/Unit/External/Database.hs
=====================================
@@ -53,9 +53,17 @@ import System.FilePath as FilePath
-- ExternalUnitDatabases
-- ----------------------------------------------------------------------------
+-- | A normalised 'OsPath' that we use as the key to cache 'UnitDatabase's.
+--
+-- Removes trailing path separators and unit database paths starting with @./@.
+newtype NormalisedUnitDbLoc = NormalisedUnitDbLoc OsPath
+ deriving (Eq, Ord)
+
-- | Caches unit databases in-memory.
data ExternalUnitDatabases unit = ExternalUnitDatabases
- { eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit))
+ { eud_cachedDatabases :: !(Map NormalisedUnitDbLoc (UnitDatabase unit))
+ -- ^ The 'Map' is keyed by a normalised 'OsPath', ensuring that 'lookupExternalUnitDatabases'
+ -- will never get confused by a stray @./@ or trailing @/@.
}
emptyExternalUnitDatabases :: ExternalUnitDatabases unit
@@ -67,18 +75,20 @@ emptyExternalUnitDatabases =
insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
insertExternalUnitDatabases unit_db eud =
ExternalUnitDatabases
- { eud_cachedDatabases = Map.insert (unitDatabasePath unit_db) unit_db (eud_cachedDatabases eud)
+ { eud_cachedDatabases =
+ Map.insert (normalisedUnitDatabaseKey unit_db) unit_db (eud_cachedDatabases eud)
}
deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
deleteExternalUnitDatabases unit_db_path eud =
ExternalUnitDatabases
- { eud_cachedDatabases = Map.delete unit_db_path (eud_cachedDatabases eud)
+ { eud_cachedDatabases =
+ Map.delete (normalisedUnitDatabaseKeyOsPath unit_db_path) (eud_cachedDatabases eud)
}
lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit)
lookupExternalUnitDatabases key eud =
- Map.lookup key (eud_cachedDatabases eud)
+ Map.lookup (normalisedUnitDatabaseKeyOsPath key) (eud_cachedDatabases eud)
-- ----------------------------------------------------------------------------
-- UnitDatabase
@@ -87,12 +97,38 @@ lookupExternalUnitDatabases key eud =
-- | Unit database entry.
data UnitDatabase unit = UnitDatabase
{ unitDatabasePath :: OsPath
+ -- ^ On-disk location of the unit database.
+ --
, unitDatabaseUnits :: [GenUnitInfo unit]
+ -- ^ Units read from the database located at 'unitDatabasePath'.
+ --
+ -- These units have the @$pkgroot@ variable already resolved.
}
instance (Outputable u) => Outputable (UnitDatabase u) where
ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp
+normalisedUnitDatabaseKey :: UnitDatabase unit -> NormalisedUnitDbLoc
+normalisedUnitDatabaseKey unit_db = normalisedUnitDatabaseKeyOsPath $ unitDatabasePath unit_db
+
+-- | Normalise the unit database location and drop trailing path separators.
+--
+-- This ensures that two databases that point to the same location can be cached.
+--
+-- We need to remove trailing slash from the 'OsPath' before calculating @$pkgroot@ (Fix #16360)
+normalisedUnitDatabaseKeyOsPath :: OsPath -> NormalisedUnitDbLoc
+normalisedUnitDatabaseKeyOsPath db_path =
+ NormalisedUnitDbLoc $ OsPath.dropTrailingPathSeparator $ OsPath.normalise db_path
+
+-- | Get the root location of a unit database.
+-- Used to replace @$pkgroot@ variables in the 'GenericUnitInfo'.
+unitDatabaseRoot :: OsPath -> OsPath
+unitDatabaseRoot p =
+ let
+ NormalisedUnitDbLoc np = normalisedUnitDatabaseKeyOsPath p
+ in
+ OsPath.takeDirectory np
+
-- ----------------------------------------------------------------------------
--
-- Merging databases
@@ -258,14 +294,12 @@ readUnitDatabase logger cfg conf_file = do
"can't find a package database at " ++ show conf_file
let
- -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
- conf_file' = OsPath.dropTrailingPathSeparator conf_file
top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg)
- pkgroot = OsPath.takeDirectory conf_file'
+ pkgroot = unitDatabaseRoot conf_file
pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
proto_pkg_configs
--
- return $ UnitDatabase conf_file' pkg_configs1
+ return $ UnitDatabase conf_file pkg_configs1
where
readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
readDirStyleUnitInfo conf_dir = do
=====================================
testsuite/tests/driver/T27836/A.hs
=====================================
@@ -0,0 +1,4 @@
+module A where
+
+a :: Int
+a = 1
=====================================
testsuite/tests/driver/T27836/B.hs
=====================================
@@ -0,0 +1,4 @@
+module B where
+
+b :: Int
+b = 1
=====================================
testsuite/tests/driver/T27836/C.hs
=====================================
@@ -0,0 +1,4 @@
+module C where
+
+b :: Int
+b = 1
=====================================
testsuite/tests/driver/T27836/Makefile
=====================================
@@ -0,0 +1,21 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T27836:
+ mkdir local-unit-db/
+ cd local-unit-db/ && '$(GHC_PKG)' init my-test.conf
+ # All these unit database paths should resolve to the same location
+ # thus after the first time parsing the unit database, we shouldn't parse it again.
+ '$(TEST_HC)' $(TEST_HC_OPTS) --make \
+ -unit @unitA -unit @unitB -unit @unitC \
+ -v2 -fforce-recomp 2>&1 \
+ | grep 'Using binary package database:'
+
+ echo ""
+ echo ""
+ echo "All -package-db variations:"
+ echo "- local-unit-db/my-test.conf"
+ echo "- ./local-unit-db/my-test.conf"
+ echo "- ./local-unit-db/my-test.conf/"
+ echo "Must be parsed only once."
=====================================
testsuite/tests/driver/T27836/T27836.stdout
=====================================
@@ -0,0 +1,8 @@
+Using binary package database: local-unit-db/my-test.conf/package.cache
+
+
+All -package-db variations:
+- local-unit-db/my-test.conf
+- ./local-unit-db/my-test.conf
+- ./local-unit-db/my-test.conf/
+Must be parsed only once.
=====================================
testsuite/tests/driver/T27836/all.T
=====================================
@@ -0,0 +1,4 @@
+test('T27836',
+ [ extra_files(['A.hs', 'B.hs', 'C.hs', 'unitA', 'unitB', 'unitC']), normalise_slashes
+ ],
+ makefile_test, ['T27836'])
=====================================
testsuite/tests/driver/T27836/unitA
=====================================
@@ -0,0 +1 @@
+-hide-all-packages -no-user-package-db -package-db local-unit-db/my-test.conf -package base -this-unit-id a-0.0.0 A
=====================================
testsuite/tests/driver/T27836/unitB
=====================================
@@ -0,0 +1 @@
+-hide-all-packages -no-user-package-db -package-db ./local-unit-db/my-test.conf -package base -this-unit-id b-0.0.0 B
=====================================
testsuite/tests/driver/T27836/unitC
=====================================
@@ -0,0 +1 @@
+-hide-all-packages -no-user-package-db -package-db ./local-unit-db/my-test.conf/ -package base -this-unit-id c-0.0.0 C
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f51b26f42c35e42035bbb46b8d0f68…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f51b26f42c35e42035bbb46b8d0f68…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/T26543b] Rename CycleBreakerTv to GivenCycleBreakerTv [skip ci]
by Simon Peyton Jones (＠simonpj) 01 Oct '26
by Simon Peyton Jones (＠simonpj) 01 Oct '26
01 Oct '26
Simon Peyton Jones pushed to branch wip/T26543b at Glasgow Haskell Compiler / GHC
Commits:
5e6c1f43 by Simon Peyton Jones at 2026-10-01T13:07:42+01:00
Rename CycleBreakerTv to GivenCycleBreakerTv [skip ci]
.. and add documentation
- - - - -
7 changed files:
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -2584,15 +2584,15 @@ turn controls the behaviour of the workhorse: GHC.Tc.Utils.Unify.checkTyEqRhs.
The details depend on whether we're working with a Given or a Wanted.
-Given
------
+Note [Type equality cycles: Givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We emit a new Given, [G] F a ~ cbv, equating the type family application
to our new cbv. This is actually done by `break_given` in
`GHC.Tc.Solver.Monad.checkTypeEq`.
-Note its orientation: The type family ends up on the left; see
-Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for
-CycleBreakerTvs is necessary. This scenario is now easily soluble, by using
+Note its orientation: The type family ends up on the left;
+see Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for
+GivenCycleBreakerTvs is necessary. This scenario is now easily soluble, by using
the first Given to rewrite the Wanted, which can now be solved.
(The first Given actually also rewrites the second one, giving
@@ -2613,10 +2613,11 @@ to
Note that
* `cbv` is a fresh cycle breaker variable.
-* `cbv` is a meta-tyvar, but it is completely untouchable.
+* `cbv` is a meta-tyvar, of flavour GivenCycleBreakerTv, but it is
+ completely untouchable.
* We track the cycle-breaker variables in inert_cycle_breakers in InertSet
-* We eventually fill in the cycle-breakers, with `cbv := F lhs`.
- No one else fills in CycleBreakerTvs!
+* We eventually fill in the cycle-breakers, with `cbv := F lhs`,
+ via `restoreTyVarCycles`. No one else fills in GivenCycleBreakerTvs!
* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know
this fill-in is ultimately going to happen.
* In `inert_cycle_breakers`, we remember the (cbv, F lhs) pair; that is, we
@@ -2626,8 +2627,8 @@ Note that
* This fill-in is done when solving is complete, by restoreTyVarCycles
in nestImplicTcS and runTcSWithEvBinds.
-Wanted
-------
+Note [Type equality cycles: Wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
First, we do not cycle-break unless the LHS is a unifiable type variable
See Note [Don't cycle-break Wanteds when not unifying] in GHC.Tc.Solver.Monad.
@@ -2686,9 +2687,9 @@ to unify the cbvs:
[W] AllEqF '[Bool] alpha
Without the logic detailed in this Note, we're stuck here, as AllEqF cannot
-reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach,
-just as described above. We thus invent cbv1 and cbv2 and unify
-alpha := cbv1 -> cbv2, yielding (after zonking)
+reduce and alpha cannot unify (occurs check). Let's instead apply our
+cycle-breaker approach, just as described above. We thus invent cbv1 and cbv2
+and unify alpha := (cbv1 : cbv2), yielding (after zonking)
[W] Head (cbv1 : cbv2) ~ cbv1
[W] Tail (cbv1 : cbv2) ~ cbv2
@@ -2726,8 +2727,8 @@ Note that we need to unify the cbvs here; if we did not, there would be
no way to solve those constraints. That's why the cycle-breakers are
ordinary TauTvs.
-How all this is implemented
----------------------------
+Note [Type equality cycles: implementation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We implement all this via the `TEFA_Break` constructor of `TyEqFamApp`,
itself stored in the `tef_fam_app` field of `TyEqFlags`, which controls
the behaviour of `GHC.Tc.Utils.Unify.checkTyEqRhs`. The `TEFA_Break`
@@ -2854,7 +2855,7 @@ More details:
CycleBreakerOrigin. This works for both Givens and Wanteds, as we need the
logic in the W case for e.g. typecheck/should_fail/T17139. Because this
logic needs to work for Wanteds, too, we cannot simply look for a
- CycleBreakerTv on the left: Wanteds don't use them.
+ GivenCycleBreakerTv on the left: Wanteds don't use them.
**********************************************************************
=====================================
compiler/GHC/Tc/Solver/InertSet.hs
=====================================
@@ -304,7 +304,7 @@ instance Outputable WorkList where
********************************************************************* -}
type CycleBreakerVarStack = NE.NonEmpty (Bag (TcTyVar, TcType))
- -- ^ a stack of (CycleBreakerTv, original family applications) lists
+ -- ^ A stack of (GivenCycleBreakerTv, original family applications) lists
-- first element in the stack corresponds to current implication;
-- later elements correspond to outer implications
-- used to undo the cycle-breaking needed to handle
@@ -324,6 +324,8 @@ data InertSet
-- See `resetInertCans`
, inert_cycle_breakers :: CycleBreakerVarStack
+ -- The equalities for /given/ cycle breakers, GivenCycleBreakerTvs
+ -- See Note [
, inert_famapp_cache :: FunEqMap Reduction
-- Just a hash-cons cache for use when reducing family applications
@@ -1942,7 +1944,8 @@ prohibitedSuperClassSolve given_loc wanted_loc
{- *********************************************************************
* *
- Cycle breakers
+ Given Cycle breakers
+ See Note [Type equality cycles: Givens] in GHC.Tc.Solver.Equality
* *
********************************************************************* -}
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -2344,12 +2344,12 @@ checkTypeEq ev eq_rel lhs rhs =
given_pred = mkNomEqPred fam_app new_ty
given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note
- -- See Detail (7) of the Note
+ -- See Detail (7) of Note [Type equality cycles: implementation]
cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
-------------------------
-- | Fill in CycleBreakerTvs with the variables they stand for.
--- See Note [Type equality cycles] in GHC.Tc.Solver.Equality
+-- See Note [Type equality cycles: Givens] in GHC.Tc.Solver.Equality
restoreTyVarCycles :: InertSet -> TcM ()
restoreTyVarCycles is
= TcM.liftZonkM
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -726,11 +726,11 @@ cloneMetaTyVarName name
metaInfoToTyVarName :: MetaInfo -> FastString
metaInfoToTyVarName meta_info =
case meta_info of
- TauTv -> fsLit "t"
- TyVarTv -> fsLit "a"
- RuntimeUnkTv -> fsLit "r"
- CycleBreakerTv -> fsLit "b"
- ConcreteTv {} -> fsLit "c"
+ TauTv -> fsLit "t"
+ TyVarTv -> fsLit "a"
+ RuntimeUnkTv -> fsLit "r"
+ GivenCycleBreakerTv -> fsLit "b"
+ ConcreteTv {} -> fsLit "c"
newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi
@@ -824,7 +824,7 @@ cloneAnonMetaTyVar info tv kind
-- in GHC.Tc.Solver.Equality.
newCycleBreakerTyVar :: TcKind -> TcM TcTyVar
newCycleBreakerTyVar kind
- = do { details <- newMetaDetails CycleBreakerTv
+ = do { details <- newMetaDetails GivenCycleBreakerTv
; name <- newMetaTyVarName (fsLit "cbv")
; return (mkTcTyVar name kind details) }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -688,9 +688,10 @@ data MetaInfo
| RuntimeUnkTv -- ^ A unification variable used in the GHCi debugger.
-- It /is/ allowed to unify with a polytype, unlike TauTv
- | CycleBreakerTv -- ^ Used to fix occurs-check problems in Givens
- -- See Note [Type equality cycles] in
- -- GHC.Tc.Solver.Equality
+ | GivenCycleBreakerTv -- ^ Used to fix occurs-check problems in Givens
+ -- Never used for Wanteds
+ -- See Note [Type equality cycles] in
+ -- GHC.Tc.Solver.Equality
| ConcreteTv ConcreteTvOrigin
-- ^ A unification variable that can only be unified
@@ -705,11 +706,11 @@ instance Outputable MetaDetails where
ppr (Indirect ty) = text "Indirect" <+> ppr ty
instance Outputable MetaInfo where
- ppr TauTv = text "tau"
- ppr TyVarTv = text "tyv"
- ppr RuntimeUnkTv = text "rutv"
- ppr CycleBreakerTv = text "cbv"
- ppr (ConcreteTv {}) = text "conc"
+ ppr TauTv = text "tau"
+ ppr TyVarTv = text "tyv"
+ ppr RuntimeUnkTv = text "rutv"
+ ppr GivenCycleBreakerTv = text "cbv"
+ ppr (ConcreteTv {}) = text "conc"
-- | What caused us to create a 'ConcreteTv' metavariable?
-- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.
@@ -1299,7 +1300,7 @@ isRuntimeUnkTyVar tv
isCycleBreakerTyVar tv
| isTyVar tv -- See Note [Coercion variables in free variable lists]
- , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv
+ , MetaTv { mtv_info = GivenCycleBreakerTv } <- tcTyVarDetails tv
= True
| otherwise
@@ -1350,8 +1351,8 @@ metaTyVarInfo tv
isTouchableInfo :: MetaInfo -> Bool
isTouchableInfo info
- | CycleBreakerTv <- info = False
- | otherwise = True
+ | GivenCycleBreakerTv <- info = False
+ | otherwise = True
metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel tv
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -3235,11 +3235,11 @@ lhsPriority tv
-> 5 -- Eliminate instantiation variables first
| otherwise
-> case info of
- CycleBreakerTv -> 0
- TyVarTv -> 1
- ConcreteTv {} -> 2
- TauTv -> 3
- RuntimeUnkTv -> 4
+ GivenCycleBreakerTv -> 0
+ TyVarTv -> 1
+ ConcreteTv {} -> 2
+ TauTv -> 3
+ RuntimeUnkTv -> 4
{- Note [Unification preconditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3285,7 +3285,7 @@ There are five reasons not to unify:
structured type. So if 'ty' is a structured type, such as (Maybe x),
don't unify.
- * CycleBreakerTv: never unified, except by restoreTyVarCycles.
+ * GivenCycleBreakerTv: never unified, except by restoreGivenCycles.
4. (CONCRETE) A ConcreteTv can only unify with a concrete type,
by definition.
@@ -3390,7 +3390,7 @@ So we look for a positive reason to swap, using a three-step test:
touchable and can be unified.
Tie-breaking rules for MetaTvs:
- - CycleBreakerTv: This is essentially a stand-in for another type;
+ - GivenCycleBreakerTv: This is essentially a stand-in for another type;
it's untouchable and should have the same priority as a skolem: 0.
- TyVarTv: These can unify only with another tyvar, but we can't unify
@@ -4112,13 +4112,14 @@ wantConcreteCheck = \case
-- where @cbv@ is a fresh loop-breaker tyvar (for Given), or
-- just a fresh 'TauTv' (for Wanted)
famAppBreaker :: FamAppBreaker a -> TcType -> TcM (PuResult a Reduction)
-famAppBreaker BreakGiven fam_app
+famAppBreaker BreakGiven fam_app -- Givens
= do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app)
; return (PuOK (unitBag (new_tv, fam_app))
(mkReflRedn Nominal (mkTyVarTy new_tv))) }
-- Why reflexive? See Detail (4) of Note [Type equality cycles]
-- in GHC.Tc.Solver.Equality
-famAppBreaker (BreakWanted ev lhs_tv) fam_app
+
+famAppBreaker (BreakWanted ev lhs_tv) fam_app -- Wanteds
-- Occurs check or skolem escape; so flatten
= do { reason <- checkPromoteFreeVars cteInsolubleOccurs
(tyVarName lhs_tv) lhs_tv_lvl
@@ -4861,7 +4862,7 @@ checkTopShape info xi
RuntimeUnk -> True
MetaTv { mtv_info = TyVarTv } -> True
_ -> False
- CycleBreakerTv -> False -- We never unify these
+ GivenCycleBreakerTv -> False -- We never unify these
_ -> True
--------------------------------------------------------------------------------
@@ -5174,14 +5175,14 @@ mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc
-- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars
-- (as they can be unified)
- -- and also for CycleBreakerTvs that mentions meta-tyvars
+ -- and also for GivenCycleBreakerTvs that mentions meta-tyvars
mentions_meta_ty_var :: TyVar -> Bool
mentions_meta_ty_var tv
| isMetaTyVar tv
= case metaTyVarInfo tv of
-- See Examples 8 and 9 in the Note
- CycleBreakerTv -> anyFreeVarsOfType mentions_meta_ty_var
- (lookupCycleBreakerVar tv inert_set)
+ GivenCycleBreakerTv -> anyFreeVarsOfType mentions_meta_ty_var
+ (lookupCycleBreakerVar tv inert_set)
_ -> True
| otherwise
= False
@@ -5224,7 +5225,7 @@ We want to solve w1 using g1 and g2. The presence of g3 is irrelevant, because
we cannot unify 'f[tau:1] v[tau:1]' and 'g[sk:1] x[sk:3]' due to skolem escape.
-}
--- | Return the type family application a CycleBreakerTv maps to.
+-- | Return the type family application a GivenCycleBreakerTv maps to.
lookupCycleBreakerVar :: TcTyVar -- ^ cbv, must be a CycleBreakerTv
-> InertSet
-> TcType -- ^ type family application the cbv maps to
=====================================
testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
=====================================
@@ -22,7 +22,7 @@ it mentions b in its RHS. It thus triggers Note [Type equality cycles]
in GHC.Tc.Solver.Equality. That Note says we change the situation to
[G] b ~ cbv GhcPs
[G] Body b ~ cbv
-for some fresh CycleBreakerTv cbv. Now, our original equality looks to be let-like,
+for some fresh GivenCycleBreakerTv cbv. Now, our original equality looks to be let-like,
but the new cbv equality is *not* let-like -- note that the variable is on the RHS.
The solution is to consider any equality whose free variables are all at the current
level to not stop equalities from floating. These are called *local*. Because both
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e6c1f43db2598cddfa54d909e2437d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5e6c1f43db2598cddfa54d909e2437d…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0