[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
01 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
24 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- 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/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/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -945,13 +945,13 @@ body :: { ([TrailingAnn]
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,EpLayout) }
: '{' top '}' { (fst $2, snd $2, epExplicitBraces $1 $3) }
- | vocurly top close { (fst $2, snd $2, EpVirtualBraces (getVOCURLY $1)) }
+ | vocurly top close { (fst $2, snd $2, EpVirtualBraces (glR $1)) }
body2 :: { ([TrailingAnn]
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,EpLayout) }
: '{' top '}' { (fst $2, snd $2, epExplicitBraces $1 $3) }
- | missing_module_keyword top close { ([], snd $2, EpVirtualBraces leftmostColumn) }
+ | missing_module_keyword top close { ([], snd $2, EpVirtualBraces (EpaDelta noSrcSpan (SameLine 0) [])) }
top :: { ([TrailingAnn]
@@ -1855,7 +1855,7 @@ decllist_cls
: '{' decls_cls '}' { sLL $1 $> ((epTok $1, fst $ unLoc $2, epTok $3)
,snd $ unLoc $2, epExplicitBraces $1 $3) }
| vocurly decls_cls close { let { L l (anns, decls) = $2 }
- in L l ((noEpTok, anns, noEpTok), decls, EpVirtualBraces (getVOCURLY $1)) }
+ in L l ((noEpTok, anns, noEpTok), decls, EpVirtualBraces (glR $1)) }
-- Class body
--
@@ -4305,7 +4305,6 @@ getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl)
getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline,FunLike)
getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline,FunLike)
getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
-getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l
getINTEGERs (L _ (ITinteger (IL src _ _))) = src
getCHARs (L _ (ITchar src _)) = src
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -5,7 +5,7 @@ module GHC.Parser.Annotation (
getEpTokenBufSpan,
getEpTokenLoc, getEpUniTokenLoc,
TokDcolon, TokDarrow, TokRarrow, TokForall, TokStar,
- EpLayout(..),
+ EpLayout(..), getEpaLocationCol,
EpaComment(..), EpaCommentTok(..),
IsUnicodeSyntax(..),
HasE(..),
@@ -282,7 +282,9 @@ data EpLayout =
-- bar :: a
-- @
EpVirtualBraces
- !Int -- ^ Layout column (indentation level, begins at 1)
+ !EpaLocation -- ^ Layout column (indentation level, begins at 1)
+ -- We keep this as an 'EpaLocation' so exact printing
+ -- can use it too.
|
-- | Empty or compiler-generated blocks do not have layout information
-- associated with them.
@@ -290,6 +292,14 @@ data EpLayout =
deriving instance Data EpLayout
+-- | Used in 'GHC.Parser.Haddock' to get layout column. It assumes
+-- | there is a RealSrcSpan in it, falling back to zero otherwise
+getEpaLocationCol :: EpaLocation -> Int
+getEpaLocationCol loc
+ = case loc of
+ EpaSpan (RealSrcSpan l _) -> srcSpanStartCol l
+ _ -> leftmostColumn -- should never happen in Parser output
+
-- ---------------------------------------------------------------------
data EpaComment =
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -392,8 +392,9 @@ addHaddockInterleaveItems layout get_doc_item = go
with_layout = case layout of
EpNoLayout -> id
EpExplicitBraces{} -> id
- EpVirtualBraces n ->
- let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }
+ EpVirtualBraces n' ->
+ let n = getEpaLocationCol n'
+ loc_range = mempty { loc_range_col = ColumnFrom (n+1) }
in hoistHdkA (inLocRange loc_range)
instance HasHaddock (LocatedA (HsDecl GhcPs)) where
@@ -1304,7 +1305,7 @@ mkDocDecl layout (L l_comment hdk_comment)
indent_mismatch = case layout of
EpNoLayout -> False
EpExplicitBraces{} -> False
- EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)
+ EpVirtualBraces n -> getEpaLocationCol n /= srcSpanStartCol (psRealSpan l_comment)
mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs)
mkDocIE (L l_comment hdk_comment) =
=====================================
testsuite/tests/ghc-api/exactprint/T22919.stderr
=====================================
@@ -34,7 +34,7 @@
{ T22919.hs:1:8-13 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T22919.hs:2:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -34,7 +34,7 @@
"-- ^ Run any arbitrary IO code")
{ Test20239.hs:7:86 }))]))
(EpVirtualBraces
- (1))
+ (EpaSpan { Test20239.hs:5:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
=====================================
@@ -40,7 +40,7 @@
"-- Trailing comment, should be in HsModule extension point")
{ ZeroWidthSemi.hs:6:5 }))]))
(EpVirtualBraces
- (1))
+ (EpaSpan { ZeroWidthSemi.hs:6:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T17544.hs:5:1 }))
(Nothing)
(Nothing))
(Just
@@ -64,7 +64,7 @@
(EpTok (EpaSpan { <no location info> }))
[])
(EpVirtualBraces
- (3)))
+ (EpaSpan { T17544.hs:6:3 })))
[]
(Nothing)
(L
@@ -243,7 +243,7 @@
(EpTok (EpaSpan { <no location info> }))
[])
(EpVirtualBraces
- (3)))
+ (EpaSpan { T17544.hs:10:3 })))
[]
(Nothing)
(L
@@ -423,7 +423,7 @@
(EpTok (EpaSpan { <no location info> }))
[])
(EpVirtualBraces
- (3)))
+ (EpaSpan { T17544.hs:14:3 })))
[]
(Nothing)
(L
@@ -603,7 +603,7 @@
(EpTok (EpaSpan { <no location info> }))
[])
(EpVirtualBraces
- (3)))
+ (EpaSpan { T17544.hs:18:3 })))
[]
(Nothing)
(L
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T17544_kw.hs:13:1 }))
(Nothing)
(Nothing))
(Just
@@ -412,7 +412,7 @@
(EpTok (EpaSpan { <no location info> }))
[])
(EpVirtualBraces
- (5)))
+ (EpaSpan { T17544_kw.hs:22:5 })))
[]
(Nothing)
(L
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T24221.hs:3:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/module/mod185.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaDelta { <no location info> } (SameLine 0) []))
(Nothing)
(Nothing))
(Nothing)
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { DumpParsedAst.hs:5:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -41,7 +41,7 @@
{ DumpParsedAstComments.hs:1:1-28 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { DumpParsedAstComments.hs:9:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -45,7 +45,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { DumpSemis.hs:4:1 }))
(Nothing)
(Nothing))
(Just
@@ -1336,7 +1336,7 @@
(EpTok (EpaSpan { <no location info> }))
[])
(EpVirtualBraces
- (3)))
+ (EpaSpan { DumpSemis.hs:29:3 })))
[]
(Nothing)
(L
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { KindSigs.hs:8:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T15323.hs:5:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T20452.hs:5:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/T20718.stderr
=====================================
@@ -68,7 +68,7 @@
"-- end 2")
{ T20718.hs:10:1-8 }))]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T20718.hs:8:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/T20718b.stderr
=====================================
@@ -55,7 +55,7 @@
{ T20718b.hs:6:1-21 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T20718b.hs:8:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/T20846.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T20846.hs:3:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/parser/should_compile/T23315/T23315.stderr
=====================================
@@ -24,7 +24,7 @@
(EpaComments
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T23315.hsig:3:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
=====================================
@@ -47,7 +47,7 @@
"-- comment post B")
{ AnnotationNoListTuplePuns.hs:17:3 }))]))
(EpVirtualBraces
- (1))
+ (EpaSpan { AnnotationNoListTuplePuns.hs:5:1 }))
(Nothing)
(Nothing))
(Just
@@ -244,7 +244,7 @@
{ AnnotationNoListTuplePuns.ppr.hs:1:1-32 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { AnnotationNoListTuplePuns.ppr.hs:4:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -28,7 +28,7 @@
[]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { T18791.hs:4:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/printer/Test20297.stdout
=====================================
@@ -34,7 +34,7 @@
{ Test20297.hs:1:1 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { Test20297.hs:5:1 }))
(Nothing)
(Nothing))
(Just
@@ -476,7 +476,7 @@
{ Test20297.ppr.hs:1:1 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { Test20297.ppr.hs:3:1 }))
(Nothing)
(Nothing))
(Just
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -34,7 +34,7 @@
{ Test24533.hs:1:1 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { Test24533.hs:4:1 }))
(Nothing)
(Nothing))
(Just
@@ -694,7 +694,7 @@
{ Test24533.ppr.hs:1:1 }))]
[]))
(EpVirtualBraces
- (1))
+ (EpaSpan { Test24533.ppr.hs:3:1 }))
(Nothing)
(Nothing))
(Just
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e358619f138494a690f47aa1f9663c8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e358619f138494a690f47aa1f9663c8…
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][master] 2 commits: Fix MultiLayerModules timeout multiplier.
by Marge Bot (＠marge-bot) 01 Oct '26
by Marge Bot (＠marge-bot) 01 Oct '26
01 Oct '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
4 changed files:
- testsuite/driver/junit.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
testsuite/driver/junit.py
=====================================
@@ -2,10 +2,33 @@ from my_typing import *
from datetime import datetime
import xml.etree.ElementTree as ET
-from testglobals import TestRun
+from testglobals import TestRun, TestResult
+
+
+def add_testcase(testsuite: ET.Element, test_result: TestResult) -> ET.Element:
+ """Adds the xml element representing the testcase."""
+ testcase = ET.SubElement(testsuite, 'testcase',
+ classname = test_result.way,
+ name = '%s(%s)' % (test_result.testname, test_result.way))
+ if test_result.runtime is not None:
+ testcase.set('time', '%.3f' % test_result.runtime)
+ return testcase
+
+def add_result(testcase: ET.Element, kind: str, res_type: str,
+ reason: Optional[str], text: str) -> ET.Element:
+ """Add a result to the testcase."""
+ # GitLab ignores the message attribute and shows only the text.
+ result = ET.SubElement(testcase, kind,
+ type = res_type,
+ message = reason or '')
+ result.text = text
+ return result
def junit(t: TestRun) -> ET.ElementTree:
- testsuites = ET.Element('testsuites')
+ # Report time spent in testsuite.
+ assert t.start_time is not None
+ elapsed = '%.3f' % (datetime.now() - t.start_time).total_seconds()
+ testsuites = ET.Element('testsuites', time = elapsed)
testsuite = ET.SubElement(testsuites, 'testsuite',
id = "0",
package = 'ghc',
@@ -15,6 +38,7 @@ def junit(t: TestRun) -> ET.ElementTree:
+ len(t.unexpected_passes)),
errors = str(len(t.framework_failures)),
skipped = str(len(t.fragile_failures)),
+ time = elapsed,
timestamp = datetime.now().isoformat())
for kind, res_type, group in [('failure', 'stat failure', t.unexpected_stat_failures),
@@ -22,9 +46,7 @@ def junit(t: TestRun) -> ET.ElementTree:
('failure', 'unexpected pass', t.unexpected_passes),
('skipped', 'fragile failure', t.fragile_failures)]:
for tr in group:
- testcase = ET.SubElement(testsuite, 'testcase',
- classname = tr.way,
- name = '%s(%s)' % (tr.testname, tr.way))
+ testcase = add_testcase(testsuite, tr)
message = [] # type: List[str]
if tr.diff:
message += ['diff:', '==========', tr.diff]
@@ -35,23 +57,16 @@ def junit(t: TestRun) -> ET.ElementTree:
if not message:
message = [tr.reason]
- result = ET.SubElement(testcase, kind,
- type = res_type,
- message = tr.reason)
- result.text = '\n'.join(message)
+ add_result(testcase, kind, res_type, tr.reason, '\n'.join(message))
for tr in t.framework_failures:
- testcase = ET.SubElement(testsuite, 'testcase',
- classname = tr.way,
- name = '%s(%s)' % (tr.testname, tr.way))
- result = ET.SubElement(testcase, 'error',
- type = "framework failure",
- message = tr.reason)
-
- for tr in t.expected_passes:
- testcase = ET.SubElement(testsuite, 'testcase',
- classname = tr.way,
- name = '%s(%s)' % (tr.testname, tr.way))
+ testcase = add_testcase(testsuite, tr)
+ add_result(testcase, 'error', 'framework failure', tr.reason, tr.reason)
+
+ # Expected failures (expect_broken) behaved as expected, so they count as
+ # passes, like in the driver's exit code.
+ for tr in t.expected_passes + t.expected_failures + t.fragile_passes:
+ add_testcase(testsuite, tr)
return ET.ElementTree(testsuites)
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -288,10 +288,10 @@ ghc_env = os.environ.copy()
class TestResult:
"""
A result from the execution of a test. These live in the expected_passes,
- framework_failures, framework_warnings, unexpected_passes,
+ expected_failures, framework_failures, framework_warnings, unexpected_passes,
unexpected_failures, unexpected_stat_failures lists of TestRun.
"""
- __slots__ = 'directory', 'testname', 'reason', 'way', 'stdout', 'stderr', 'diff'
+ __slots__ = 'directory', 'testname', 'reason', 'way', 'stdout', 'stderr', 'diff', 'runtime'
def __init__(self,
directory: str,
testname: TestName,
@@ -299,7 +299,8 @@ class TestResult:
way: WayName,
stdout: Optional[str]=None,
stderr: Optional[str]=None,
- diff: Optional[str]=None) -> None:
+ diff: Optional[str]=None,
+ runtime: Optional[float]=None) -> None:
self.directory = directory
self.testname = testname
self.reason = reason
@@ -307,6 +308,7 @@ class TestResult:
self.stdout = stdout
self.stderr = stderr
self.diff = diff
+ self.runtime = runtime # Walltime
# A performance metric measured in this test run.
PerfMetric = NamedTuple('PerfMetric',
@@ -322,13 +324,12 @@ class TestRun:
self.n_tests_skipped = 0
self.n_missing_libs = 0
- self.n_expected_passes = 0
- self.n_expected_failures = 0
self.framework_failures = [] # type: List[TestResult]
self.framework_warnings = [] # type: List[TestResult]
self.expected_passes = [] # type: List[TestResult]
+ self.expected_failures = [] # type: List[TestResult]
self.unexpected_passes = [] # type: List[TestResult]
self.unexpected_failures = [] # type: List[TestResult]
self.unexpected_stat_failures = [] # type: List[TestResult]
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1706,13 +1706,15 @@ async def test_common_work(name: TestName, opts,
for way in do_ways:
if stopping():
break
+ start = time.monotonic()
try:
await do_test(name, way, func, args, files)
except KeyboardInterrupt:
stopNow()
except Exception as e:
traceback.print_exc()
- framework_fail(name, way, traceback.format_exc())
+ framework_fail(name, way, traceback.format_exc(),
+ runtime=time.monotonic() - start)
t.n_tests_skipped += len(set(all_ways) - set(do_ways))
if getTestOpts().expect == 'missing-lib': t.n_missing_libs += 1
@@ -1738,6 +1740,7 @@ async def do_test(name: TestName,
files: Set[str]
) -> None:
opts = getTestOpts()
+ start = time.monotonic()
full_name = name + '(' + way + ')'
test_n = len(allTestNames)
@@ -1787,7 +1790,8 @@ async def do_test(name: TestName,
pass
else:
framework_fail(name, way,
- 'extra_file does not exist: ' + extra_file)
+ 'extra_file does not exist: ' + extra_file,
+ runtime=time.monotonic() - start)
if func.__name__ == 'run_command' or func.__name__ == 'makefile_test' or opts.pre_cmd:
# When running 'MAKE' make sure 'TOP' still points to the
@@ -1811,7 +1815,8 @@ async def do_test(name: TestName,
# If user used expect_broken then don't record failures of pre_cmd
if exit_code != 0 and opts.expect not in ['fail']:
- framework_fail(name, way, 'pre_cmd failed: {0}'.format(exit_code))
+ framework_fail(name, way, 'pre_cmd failed: {0}'.format(exit_code),
+ runtime=time.monotonic() - start)
if_verbose(1, '** pre_cmd was "{0}".'.format(override_options(opts.pre_cmd)))
stderr_contents = stderr_path.read_text(encoding='UTF-8', errors='replace')
stdout_contents = stdout_path.read_text(encoding='UTF-8', errors='replace')
@@ -1821,45 +1826,54 @@ async def do_test(name: TestName,
return
result = await func(*[name,way] + args)
+ runtime = time.monotonic() - start
if opts.expect not in ['pass', 'fail', 'missing-lib']:
- framework_fail(name, way, 'bad expected ' + opts.expect)
+ framework_fail(name, way, 'bad expected ' + opts.expect, runtime=runtime)
directory = _result_directory(opts)
if way in opts.fragile_ways:
if_verbose(1, '*** fragile test %s resulted in %s' % (full_name, 'pass' if result.passed else 'fail'))
if result.passed:
- t.fragile_passes.append(TestResult(directory, name, 'fragile', way))
+ t.fragile_passes.append(TestResult(directory, name, 'fragile', way,
+ runtime=runtime))
else:
reason = '%s (fragile)' % result.reason if result.reason else 'fragile'
t.fragile_failures.append(TestResult(directory, name, reason, way,
stdout=result.stdout,
stderr=result.stderr,
- diff=result.diff))
+ diff=result.diff,
+ runtime=runtime))
elif result.passed:
if _expect_pass(way):
- t.expected_passes.append(TestResult(directory, name, "", way))
- t.n_expected_passes += 1
+ t.expected_passes.append(TestResult(directory, name, "", way,
+ runtime=runtime))
else:
if_verbose(1, '*** unexpected pass for %s' % full_name)
- t.unexpected_passes.append(TestResult(directory, name, 'unexpected', way))
+ t.unexpected_passes.append(TestResult(directory, name, 'unexpected', way,
+ runtime=runtime))
else:
if _expect_pass(way):
reason = result.reason
tag = result.tag
if tag == 'stat':
if_verbose(1, '*** unexpected stat test failure for %s' % full_name)
- t.unexpected_stat_failures.append(TestResult(directory, name, reason, way))
+ t.unexpected_stat_failures.append(TestResult(directory, name, reason, way,
+ runtime=runtime))
else:
if_verbose(1, '*** unexpected failure for %s' % full_name)
tr = TestResult(directory, name, reason, way,
stdout=result.stdout,
stderr=result.stderr,
- diff=result.diff)
+ diff=result.diff,
+ runtime=runtime)
t.unexpected_failures.append(tr)
else:
- t.n_expected_failures += 1
+ # Only keep the reason: nothing reports the output of expected
+ # failures.
+ t.expected_failures.append(TestResult(directory, name, result.reason, way,
+ runtime=runtime))
# Make is often invoked with -s, which means if it fails, we get
# no feedback at all. This is annoying. So let's remove the option
@@ -1873,7 +1887,8 @@ def override_options(pre_cmd):
return pre_cmd
-def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str) -> None:
+def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str,
+ runtime: Optional[float]=None) -> None:
opts = getTestOpts()
# framework_fail can be called before testdir is initialised,
# so we need to take care not to blow up with the wrong way
@@ -1888,7 +1903,8 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str
way2 = way if way is not None else WayName('none')
if way not in opts.fragile_ways:
# If the test is fragile then we rather report this as a fragile test failure
- t.framework_failures.append(TestResult(directory, name2, reason, way2))
+ t.framework_failures.append(TestResult(directory, name2, reason, way2,
+ runtime=runtime))
def framework_warn(name: TestName, way: WayName, reason: str) -> None:
opts = getTestOpts()
@@ -3649,9 +3665,9 @@ def summary(t: TestRun, file: TextIO, color=False, junit_path: Optional[Path]=No
+ repr(t.n_missing_libs).rjust(8)
+ ' had missing libraries\n'
+ '\n'
- + repr(t.n_expected_passes).rjust(8)
+ + repr(len(t.expected_passes)).rjust(8)
+ ' expected passes\n'
- + repr(t.n_expected_failures).rjust(8)
+ + repr(len(t.expected_failures)).rjust(8)
+ ' expected failures\n'
+ '\n'
+ repr(len(t.framework_failures)).rjust(8)
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -363,15 +363,20 @@ test('T13379',
# (though the size of the fluctuations does perhaps suggest that it
# would be valuable to solve the pathology in a more general way).
+# Note [MultiLayerModules* test timeout]
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# These tests are relatively sensitive to system load and cane
+# take a while to run. This caused a fair number of CI failures
+# in the past. So we give them some headroom.
+# We need to ensure to use the right timeout for those test. In the past
+# we used the compile timeout for the GHCi versions by accident.
+
test('MultiLayerModules',
[ collect_compiler_stats('bytes allocated',2),
pre_cmd('./genMultiLayerModules'),
extra_files(['genMultiLayerModules']),
+ # See Note [MultiLayerModules* test timeout]
compile_timeout_multiplier(5)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
],
multimod_compile,
# see Note [Increased initial stack size for MultiLayerModules]
@@ -382,11 +387,8 @@ test('MultiLayerModulesRecomp',
[ collect_compiler_stats('bytes allocated',2),
pre_cmd('$MAKE -s --no-print-directory MultiModulesRecomp'),
extra_files(['genMultiLayerModules']),
+ # See Note [MultiLayerModules* test timeout]
compile_timeout_multiplier(5)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
],
multimod_compile,
# see Note [Increased initial stack size for MultiLayerModules]
@@ -398,6 +400,7 @@ test('MultiLayerModulesTH_Make',
[ collect_compiler_stats('bytes allocated',2),
pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_Make_Prep'),
extra_files(['genMultiLayerModulesTH']),
+ # See Note [MultiLayerModules* test timeout]
compile_timeout_multiplier(5),
when(arch('wasm32'), fragile(25336)),
# We skip the test on darwin due to recent regression due to toolchain
@@ -413,6 +416,7 @@ test('MultiLayerModulesTH_OneShot',
[ collect_compiler_stats('bytes allocated',2),
pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_OneShot_Prep'),
extra_files(['genMultiLayerModulesTH']),
+ # See Note [MultiLayerModules* test timeout]
compile_timeout_multiplier(5),
when(arch('wasm32'), fragile(25336)),
# We skip the test on darwin due to recent regression due to toolchain
@@ -427,11 +431,8 @@ test('MultiLayerModulesDefsGhci',
[ collect_compiler_residency(15),
pre_cmd('./genMultiLayerModulesDefs'),
extra_files(['genMultiLayerModulesDefs']),
- compile_timeout_multiplier(5)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
+ # See Note [MultiLayerModules* test timeout]
+ run_timeout_multiplier(5)
],
ghci_script,
['MultiLayerModulesDefsGhci.script'])
@@ -440,11 +441,9 @@ test('MultiLayerModulesDefsGhciWithCore',
[ collect_compiler_residency(15),
pre_cmd('$MAKE -s --no-print-directory MultiModulesRecompDefsWithCore'),
extra_files(['genMultiLayerModulesCore', 'MultiLayerModulesDefsGhciWithCore.script']),
- compile_timeout_multiplier(5),
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
+ # See Note [MultiLayerModules* test timeout]
+ pre_cmd_timeout_multiplier(5),
+ run_timeout_multiplier(5),
extra_run_opts('-fwrite-if-simplified-core MultiLayerModules')
],
ghci_script,
@@ -454,11 +453,9 @@ test('MultiLayerModulesDefsGhciWithBytecodeFiles',
[ collect_compiler_residency(15),
pre_cmd('$MAKE -s --no-print-directory MultiModulesRecompDefsWithBytecodeFiles'),
extra_files(['genMultiLayerModulesCore', 'MultiLayerModulesDefsGhciWithBytecodeFiles.script']),
- compile_timeout_multiplier(5),
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
+ # See Note [MultiLayerModules* test timeout]
+ pre_cmd_timeout_multiplier(5),
+ run_timeout_multiplier(5),
extra_run_opts('-fwrite-byte-code MultiLayerModules')
],
ghci_script,
@@ -468,11 +465,8 @@ test('MultiLayerModulesDefsGhcWithCore',
[ collect_compiler_residency(15),
pre_cmd('$MAKE -s --no-print-directory MultiModulesDefsWithCore'),
extra_files(['genMultiLayerModulesCore']),
+ # See Note [MultiLayerModules* test timeout]
compile_timeout_multiplier(5)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
],
multimod_compile,
['MultiLayerModules', '-v0 -fwrite-if-simplified-core'])
@@ -481,11 +475,8 @@ test('MultiLayerModulesDefsGhciReload',
[ collect_compiler_residency(15),
pre_cmd('./genMultiLayerModulesDefs'),
extra_files(['genMultiLayerModulesDefs']),
- compile_timeout_multiplier(10)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
+ # See Note [MultiLayerModules* test timeout]
+ run_timeout_multiplier(5)
],
ghci_script,
['MultiLayerModulesDefsGhciReload.script'])
@@ -504,11 +495,8 @@ test('InstanceMatching1',
[ collect_compiler_stats('bytes allocated',3),
pre_cmd('./genMatchingTest 1'),
extra_files(['genMatchingTest']),
+ # See Note [MultiLayerModules* test timeout]
compile_timeout_multiplier(5)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
],
multimod_compile,
['Defs', '-fno-code -fwrite-interface -v0'])
@@ -518,11 +506,8 @@ test('MultiLayerModulesNoCode',
[ collect_compiler_residency(15),
pre_cmd('./genMultiLayerModulesNoCode'),
extra_files(['genMultiLayerModulesNoCode']),
- compile_timeout_multiplier(5)
- # this is _a lot_
- # but this test has been failing every now and then,
- # especially on i386. Let's just give it some room
- # to complete successfully reliably everywhere.
+ # See Note [MultiLayerModules* test timeout]
+ run_timeout_multiplier(5)
],
ghci_script,
['MultiLayerModulesNoCode.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c406135cc3aa0379caa402e16e1a1a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c406135cc3aa0379caa402e16e1a1a…
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
01 Oct '26
Marge Bot pushed to branch master 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
- - - - -
10 changed files:
- + changelog.d/T27830-rts-flag-bounds
- docs/users_guide/runtime_control.rst
- rts/RtsFlags.c
- rts/include/rts/Flags.h
- rts/include/rts/storage/GC.h
- rts/sm/GC.c
- rts/sm/Storage.c
- testsuite/tests/rts/all.T
- testsuite/tests/rts/rtsflags001.stderr-ws-32
- testsuite/tests/rts/rtsflags001.stderr-ws-64
Changes:
=====================================
changelog.d/T27830-rts-flag-bounds
=====================================
@@ -0,0 +1,17 @@
+section: rts
+synopsis: Update RTS flag handling: It now respects user set -n values, allows resetting of more settings to defaults and gives more accurate bounds in errors.
+description:
+ 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.
+
+ A nursery chunk size (``-n``) larger than the allocation area (``-A``) now prints a
+ warning and disables nursery chunking. Previously every nursery was enlarged to the chunk size.
+
+ The number of generations (``-G``) is now limited to 64.
+issues: #27830 #27829
+mrs: !16713
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -493,7 +493,7 @@ performance.
Sets the limit on the total size of "large objects" (objects
larger than about 3KB) that can be allocated before a GC is
triggered. By default this limit is the same as the :rts-flag:`-A <-A
- ⟨size⟩>` value.
+ ⟨size⟩>` value. ``-AL0`` restores the default.
Large objects are not allocated from the normal allocation area
set by the ``-A`` flag, which is why there is a separate limit for
@@ -635,10 +635,11 @@ performance.
Set the number of generations used by the garbage
collector. The default of 2 seems to be good, but the garbage
- collector can support any number of generations. Anything larger
+ collector can in theory support any number of generations. Anything larger
than about 4 is probably not a good idea unless your program runs
for a *long* time, because the oldest generation will hardly ever
- get collected.
+ get collected. Currently the RTS hardcodes a limit of 64 generations which
+ seems plenty.
Specifying 1 generation with ``+RTS -G1`` gives you a simple 2-space
collector, as you would expect. In a 2-space collector, the :rts-flag:`-A
@@ -731,6 +732,9 @@ performance.
the default small ``-A`` value is suboptimal, as it can be in
programs that create large amounts of long-lived data.
+ ``-H0`` resets both the size suggestion, and dynamic scaling enablied by a
+ bare ``-H``.
+
.. rts-flag:: -I ⟨seconds⟩
:default: 0.3 seconds in the threaded runtime, 0 in the non-threaded runtime
@@ -886,7 +890,7 @@ performance.
of the program. The only reason for having this option is to stop
the heap growing without bound and filling up all the available swap
space, which at the least will result in the program being summarily
- killed by the operating system.
+ killed by the operating system. ``-M0`` resets any limit set by ``-M<size>``.
The maximum heap size also affects other garbage collection
parameters: when the amount of live data in the heap exceeds a
=====================================
rts/RtsFlags.c
=====================================
@@ -101,7 +101,8 @@ static int openStatsFile (
char *filename, const char *FILENAME_FMT, FILE **file_ret);
static StgWord64 decodeSize (
- const char *flag, uint32_t offset, StgWord64 min, StgWord64 max);
+ const char *flag, uint32_t offset, StgWord64 min, StgWord64 max,
+ bool allow_zero);
static double parseDouble (
const char *arg, bool *error);
@@ -141,8 +142,8 @@ void initRtsFlagsDefaults(void)
if (maxStkSize == 0)
maxStkSize = 8 * 1024 * 1024;
// GcFlags.maxStkSiz is 32-bit, so we need to cap to prevent overflow (#17019)
- else if (maxStkSize > UINT32_MAX * sizeof(W_))
- maxStkSize = UINT32_MAX * sizeof(W_);
+ else if (maxStkSize > (StgWord64) UINT32_MAX * sizeof(W_))
+ maxStkSize = (StgWord64) UINT32_MAX * sizeof(W_);
RtsFlags.GcFlags.statsFile = NULL;
RtsFlags.GcFlags.giveStats = NO_GC_STATS;
@@ -155,7 +156,7 @@ void initRtsFlagsDefaults(void)
/* -A default. See #16499 for a discussion about the tradeoffs */
RtsFlags.GcFlags.minAllocAreaSize = (4 * 1024 * 1024) / BLOCK_SIZE;
RtsFlags.GcFlags.largeAllocLim = 0; /* defaults to minAllocAreasize */
- RtsFlags.GcFlags.nurseryChunkSize = 0;
+ RtsFlags.GcFlags.nurseryChunkSize = -1; /* -1: Nothing set by user, normalized to off by default, 0: off explicitly, <n>: explicit size*/
RtsFlags.GcFlags.minOldGenSize = (1024 * 1024) / BLOCK_SIZE; /* -O default */
RtsFlags.GcFlags.maxHeapSize = 0; /* off by default */
RtsFlags.GcFlags.heapLimitGrace = (1024 * 1024);
@@ -331,7 +332,7 @@ usage_text[] = {
" --copying-gc",
" Selects the copying garbage collector to manage all generations.",
"",
-" -K<size> Sets the maximum stack size (default: 80% of the heap)",
+" -K<size> Sets the maximum stack size (0 = unlimited, default: 80% of the heap)",
" e.g.: -K32k -K512k -K8M",
" -ki<size> Sets the initial thread stack size (default 1k) e.g.: -ki4k -ki2m",
" -kc<size> Sets the stack chunk size (default 32k)",
@@ -349,9 +350,9 @@ usage_text[] = {
" memory controlled by this factor (higher is slower). Setting the factor",
" to 0 means memory is not returned.",
" (default 4.0)",
-" -n<size> Allocation area chunk size (0 = disabled, default: 0)",
+" -n<size> Allocation area chunk size (0 = disabled, default: 0, 4m for -A >= 16m)",
" -O<size> Sets the minimum size of the old generation (default 1M)",
-" -M<size> Sets the maximum heap size (default unlimited) e.g.: -M256k -M1G",
+" -M<size> Sets the maximum heap size (0 = unlimited, default unlimited) e.g.: -M256k -M1G",
" -H<size> Sets the minimum heap size (default 0M) e.g.: -H24m -H1G",
" -xb<addr> Sets the address from which a suitable start for the heap memory",
" will be searched from. This is useful if the default address",
@@ -1239,19 +1240,19 @@ error = true;
if (rts_argv[arg][2] == 'L') {
RtsFlags.GcFlags.largeAllocLim
= decodeSize(rts_argv[arg], 3, 2*BLOCK_SIZE,
- HS_INT_MAX) / BLOCK_SIZE;
+ (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true) / BLOCK_SIZE;
} else {
// minimum two blocks in the nursery, so that we have one
// to grab for allocate().
RtsFlags.GcFlags.minAllocAreaSize
= decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE,
- HS_INT_MAX) / BLOCK_SIZE;
+ (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, false) / BLOCK_SIZE;
}
break;
case 'n':
OPTION_UNSAFE;
RtsFlags.GcFlags.nurseryChunkSize
- = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, HS_INT_MAX)
+ = decodeSize(rts_argv[arg], 2, 2*BLOCK_SIZE, ((StgWord64) HS_INT32_MAX) * BLOCK_SIZE, true)
/ BLOCK_SIZE;
break;
@@ -1301,9 +1302,14 @@ error = true;
case 'K':
OPTION_UNSAFE;
- RtsFlags.GcFlags.maxStkSize =
- decodeSize(rts_argv[arg], 2, 0, UINT32_MAX)
- / sizeof(W_);
+ // -K and -K0 mean unlimited.
+ if (rts_argv[arg][2] == '\0') {
+ RtsFlags.GcFlags.maxStkSize = 0;
+ } else {
+ RtsFlags.GcFlags.maxStkSize =
+ decodeSize(rts_argv[arg], 2, sizeof(W_), (StgWord64) UINT32_MAX * sizeof(W_), true)
+ / sizeof(W_);
+ }
break;
case 'k':
@@ -1311,22 +1317,22 @@ error = true;
switch(rts_argv[arg][2]) {
case 'c':
RtsFlags.GcFlags.stkChunkSize =
- decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX)
+ decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false)
/ sizeof(W_);
break;
case 'b':
RtsFlags.GcFlags.stkChunkBufferSize =
- decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX)
+ decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false)
/ sizeof(W_);
break;
case 'i':
RtsFlags.GcFlags.initialStkSize =
- decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX)
+ decodeSize(rts_argv[arg], 3, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false)
/ sizeof(W_);
break;
default:
RtsFlags.GcFlags.initialStkSize =
- decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX)
+ decodeSize(rts_argv[arg], 2, sizeof(W_), (StgWord64)HS_WORD32_MAX * sizeof(W_), false)
/ sizeof(W_);
break;
}
@@ -1336,10 +1342,10 @@ error = true;
OPTION_UNSAFE;
if (0 == strncmp("grace=", rts_argv[arg] + 2, 6)) {
RtsFlags.GcFlags.heapLimitGrace =
- decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX);
+ decodeSize(rts_argv[arg], 8, BLOCK_SIZE, HS_WORD_MAX, false);
} else {
RtsFlags.GcFlags.maxHeapSize =
- decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX)
+ decodeSize(rts_argv[arg], 2, BLOCK_SIZE, (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true)
/ BLOCK_SIZE;
// user give size in *bytes* but "maxHeapSize" is in
// *blocks*
@@ -1388,8 +1394,9 @@ error = true;
#endif
case 'G':
OPTION_UNSAFE;
- RtsFlags.GcFlags.generations =
- decodeSize(rts_argv[arg], 2, 1, HS_INT_MAX);
+ // Capped at 64 by hardcoded array size in non-threaded RTS.
+ RtsFlags.GcFlags.generations = (uint32_t)
+ decodeSize(rts_argv[arg], 2, 1, GC_MAX_GENERATIONS, false);
break;
case 'H':
@@ -1398,8 +1405,12 @@ error = true;
RtsFlags.GcFlags.heapSizeSuggestionAuto = true;
} else {
RtsFlags.GcFlags.heapSizeSuggestion = (uint32_t)
- (decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX)
+ (decodeSize(rts_argv[arg], 2, BLOCK_SIZE, (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, true)
/ BLOCK_SIZE);
+ // -H0 resets to the default of no suggestion.
+ if (RtsFlags.GcFlags.heapSizeSuggestion == 0) {
+ RtsFlags.GcFlags.heapSizeSuggestionAuto = false;
+ }
}
break;
@@ -1407,7 +1418,7 @@ error = true;
OPTION_UNSAFE;
RtsFlags.GcFlags.minOldGenSize =
(uint32_t)(decodeSize(rts_argv[arg], 2, BLOCK_SIZE,
- HS_WORD_MAX)
+ (StgWord64) HS_WORD32_MAX * BLOCK_SIZE, false)
/ BLOCK_SIZE);
break;
@@ -1852,14 +1863,14 @@ error = true;
case 'q':
OPTION_UNSAFE;
RtsFlags.GcFlags.allocLimitGrace
- = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX)
+ = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX, false)
/ BLOCK_SIZE;
break;
case 'r':
OPTION_UNSAFE;
RtsFlags.GcFlags.addressSpaceSize
- = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX);
+ = decodeSize(rts_argv[arg], 3, MBLOCK_SIZE, HS_WORD64_MAX, false);
break;
default:
@@ -1994,9 +2005,25 @@ static void normaliseRtsOpts (void)
RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
}
- // If we have -A16m or larger, use -n4m.
- if (RtsFlags.GcFlags.minAllocAreaSize >= (16*1024*1024) / BLOCK_SIZE) {
- RtsFlags.GcFlags.nurseryChunkSize = (4*1024*1024) / BLOCK_SIZE;
+ // If no explicit size was given, and we have -A16m or larger, use -n4m.
+ if (RtsFlags.GcFlags.nurseryChunkSize == -1) {
+ if (RtsFlags.GcFlags.minAllocAreaSize >= (16*1024*1024) / BLOCK_SIZE) {
+ RtsFlags.GcFlags.nurseryChunkSize = (4*1024*1024) / BLOCK_SIZE;
+ } else {
+ RtsFlags.GcFlags.nurseryChunkSize = 0;
+ }
+ }
+ else if ( RtsFlags.GcFlags.nurseryChunkSize > 0 && RtsFlags.GcFlags.nurseryChunkSize < 2) {
+ errorBelch("nursery chunk size (-n) must be at least %" FMT_Word " large.", (W_)(2 * BLOCK_SIZE));
+ errorBelch("Disabling nursery chunking");
+ RtsFlags.GcFlags.nurseryChunkSize = 0;
+ }
+ // If the user gave a chunk size respect it, unless it's larger than
+ // minimum allocation area.
+ else if ( (StgWord64) RtsFlags.GcFlags.nurseryChunkSize > (StgWord64) RtsFlags.GcFlags.minAllocAreaSize) {
+ errorBelch("warning: nursery chunk size (-n) is bigger than minimum alloc area size (-A), "
+ "disabling nursery chunking");
+ RtsFlags.GcFlags.nurseryChunkSize = 0;
}
if (RtsFlags.ParFlags.parGcLoadBalancingGen == ~0u) {
@@ -2144,10 +2171,14 @@ static void initStatsFile (FILE *f)
/* -----------------------------------------------------------------------------
* decodeSize: parse a string containing a size, like 300K or 1.2M
+ *
+ * The result must lie within [min, max]. If allow_zero is set an explicitly
+ * given zero (e.g. "-M0") is accepted as well.
-------------------------------------------------------------------------- */
static StgWord64
-decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max)
+decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max,
+ bool allow_zero)
{
const char *s;
StgDouble m;
@@ -2206,10 +2237,14 @@ decodeSize(const char *flag, uint32_t offset, StgWord64 min, StgWord64 max)
val = (StgWord64)m;
- if (m < 0 || val < min || val > max) {
- // printf doesn't like 64-bit format specs on Windows
- // apparently, so fall back to unsigned long.
- errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word " - %" FMT_Word ")", flag, (W_)min, (W_)max);
+ // Only a explicit zero-digit is accepted for allow_zero.
+ bool explicit_zero = allow_zero && *s != '\0' && m == 0;
+ if (m < 0 || (val < min && !explicit_zero) || val > max) {
+ if (allow_zero && min > 0) {
+ errorBelch("error in RTS option %s: size outside allowed range (0 or %" FMT_Word64 " - %" FMT_Word64 ")", flag, (StgWord64)min, (StgWord64)max);
+ } else {
+ errorBelch("error in RTS option %s: size outside allowed range (%" FMT_Word64 " - %" FMT_Word64 ")", flag, (StgWord64)min, (StgWord64)max);
+ }
stg_exit(EXIT_FAILURE);
}
=====================================
rts/include/rts/Flags.h
=====================================
@@ -45,7 +45,7 @@ typedef struct _GC_FLAGS {
uint32_t maxHeapSize; /* in *blocks* */
uint32_t minAllocAreaSize; /* in *blocks* */
uint32_t largeAllocLim; /* in *blocks* */
- uint32_t nurseryChunkSize; /* in *blocks* */
+ int32_t nurseryChunkSize; /* in *blocks*, int to distinguish default off, vs explicit off */
uint32_t minOldGenSize; /* in *blocks* */
uint32_t heapSizeSuggestion; /* in *blocks* */
bool heapSizeSuggestionAuto;
@@ -80,7 +80,7 @@ typedef struct _GC_FLAGS {
* to handle the exception before we
* raise it again.
*/
- StgWord heapLimitGrace; /* units: *blocks*
+ StgWord heapLimitGrace; /* units: *bytes*
* After a HeapOverflow exception has
* been raised, how much extra space is
* given to the thread to handle the
=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -52,6 +52,8 @@
// ie. StgWord. Note that we have had some tricky int overflows in a
// couple of cases caused by using ints rather than longs (e.g. #5086)
+#define GC_MAX_GENERATIONS 64
+
typedef StgWord memcount;
typedef struct nursery_ {
=====================================
rts/sm/GC.c
=====================================
@@ -154,7 +154,7 @@ static Condition gc_exit_leave_now_cv;
#else // THREADED_RTS
// Must match the alignment of gen_workspace.
-StgWord8 the_gc_thread[sizeof(gc_thread) + 64 * sizeof(gen_workspace)]
+StgWord8 the_gc_thread[sizeof(gc_thread) + GC_MAX_GENERATIONS * sizeof(gen_workspace)]
ATTRIBUTE_ALIGNED(GEN_WORKSPACE_ALIGNMENT);
#endif // THREADED_RTS
=====================================
rts/sm/Storage.c
=====================================
@@ -273,7 +273,7 @@ void storageAddCapabilities (uint32_t from, uint32_t to)
if (RtsFlags.GcFlags.nurseryChunkSize == 0) {
new_n_nurseries = to;
} else {
- memcount total_alloc = to * RtsFlags.GcFlags.minAllocAreaSize;
+ memcount total_alloc = to * (size_t) RtsFlags.GcFlags.minAllocAreaSize;
new_n_nurseries =
stg_max(to, total_alloc / RtsFlags.GcFlags.nurseryChunkSize);
}
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -171,7 +171,7 @@ test('T3424',
# Test for out-of-range heap size
test('rtsflags001', [ only_ways(['normal']),
exit_code(1),
- extra_run_opts('+RTS -H0m -RTS'),
+ extra_run_opts('+RTS -H1k -RTS'),
js_skip # JS backend uses its own rts.
],
compile_and_run, [''])
=====================================
testsuite/tests/rts/rtsflags001.stderr-ws-32
=====================================
@@ -1 +1 @@
-rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 4294967295)
+rtsflags001: error in RTS option -H1k: size outside allowed range (0 or 4096 - 17592186040320)
=====================================
testsuite/tests/rts/rtsflags001.stderr-ws-64
=====================================
@@ -1 +1 @@
-rtsflags001: error in RTS option -H0m: size outside allowed range (4096 - 18446744073709551615)
+rtsflags001: error in RTS option -H1k: size outside allowed range (0 or 4096 - 17592186040320)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c406135cc3aa0379caa402e16e1a1ac…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c406135cc3aa0379caa402e16e1a1ac…
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] Statically guarantee the information reduction for 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:
260b75fc by Wolfgang Jeltsch at 2026-10-01T13:55:13+03:00
Statically guarantee the information reduction for the PIT
- - - - -
23 changed files:
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main/Interactive.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Driver/Session/Inspect.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Load.hs-boot
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/Module/ModIface.hs
- ghc/Main.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -688,7 +688,8 @@ expandFixedModuleNode key loc = do
-- part of the compiler.
lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
Just iface -> return (M.Succeeded iface)
- Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
+ Nothing -> fmap shrinkModIface <$>
+ readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
case read_result of
M.Succeeded iface -> do
-- Computer information about this node
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -372,10 +372,10 @@ lookupIfaceByModule
:: HomeUnitGraph
-> PackageIfaceTable
-> Module
- -> IO (Maybe ModIface)
+ -> IO (Maybe RetainedModIface)
lookupIfaceByModule hug pit mod
= HUG.lookupHugByModule mod hug >>= pure . \case
- Just hm -> Just (hm_iface hm)
+ Just hm -> Just (shrinkModIface (hm_iface hm))
Nothing -> lookupModuleEnv pit mod
-- If the module does come from the home package, why do we look in the PIT as well?
-- (a) In OneShot mode, even home-package modules accumulate in the PIT
@@ -384,7 +384,7 @@ lookupIfaceByModule hug pit mod
-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
-- of its own, but it doesn't seem worth the bother.
-lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface)
+lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe RetainedModIface)
lookupIfaceByModuleHsc hsc_env mod = do
eps <- hscEPS hsc_env
lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod
=====================================
compiler/GHC/Driver/Main/Interactive.hs
=====================================
@@ -148,7 +148,7 @@ hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env name
= runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name
-hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
+hscGetModuleInterface :: HscEnv -> Module -> IO RetainedModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod
@@ -270,7 +270,7 @@ hscCheckSafe' m l = do
_ | isHomeModule home_unit mod -> True
_ -> isUnitTrusted unit_state (moduleUnit m)
- lookup' :: Module -> Hsc (Maybe ModIface)
+ lookup' :: Module -> Hsc (Maybe RetainedModIface)
lookup' m = do
hsc_env <- getHscEnv
iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m
=====================================
compiler/GHC/Driver/Main/Passes.hs
=====================================
@@ -1335,7 +1335,7 @@ hscCheckSafe' m l = do
_ | isHomeModule home_unit mod -> True
_ -> isUnitTrusted unit_state (moduleUnit m)
- lookup' :: Module -> Hsc (Maybe ModIface)
+ lookup' :: Module -> Hsc (Maybe RetainedModIface)
lookup' m = do
hsc_env <- getHscEnv
iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -224,7 +224,7 @@ data PluginWithArgs = PluginWithArgs
data LoadedPlugin = LoadedPlugin
{ lpPlugin :: PluginWithArgs
-- ^ the actual plugin together with its commandline arguments
- , lpModule :: ModIface
+ , lpModule :: RetainedModIface
-- ^ the module containing the plugin
}
=====================================
compiler/GHC/Driver/Session/Inspect.hs
=====================================
@@ -87,7 +87,7 @@ data ModuleInfo = ModuleInfo {
minf_type_env :: TypeEnv,
minf_exports :: [AvailInfo],
minf_instances :: [ClsInst],
- minf_iface :: Maybe ModIface,
+ minf_iface :: Maybe RetainedModIface,
minf_safe :: SafeHaskellMode,
minf_modBreaks :: Maybe InternalModBreaks
}
@@ -140,7 +140,7 @@ getHomeModuleInfo hsc_env mdl =
Nothing -> return Nothing
Just hmi -> do
let details = hm_details hmi
- iface = hm_iface hmi
+ iface = shrinkModIface (hm_iface hmi)
return (Just (ModuleInfo {
minf_type_env = md_types details,
minf_exports = md_exports details,
@@ -187,7 +187,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do
Just tyThing -> return (Just tyThing)
Nothing -> liftIO (lookupType hsc_env name)
-modInfoIface :: ModuleInfo -> Maybe ModIface
+modInfoIface :: ModuleInfo -> Maybe RetainedModIface
modInfoIface = minf_iface
-- | Retrieve module safe haskell mode
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -276,7 +276,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u
-- a) we used something from it; has something in used_names
-- b) we imported it, even if we used nothing from it
-- (need to recompile if its export list changes: export_fprint)
- mkUsage :: Module -> ModIface -> Maybe Usage
+ mkUsage :: Module -> RetainedModIface -> Maybe Usage
mkUsage mod iface
| toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids
= Just $ UsagePackageModule{ usg_mod = mod,
@@ -302,9 +302,9 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u
usg_entities = Map.toList ent_hashs,
usg_safe = imp_safe }
where
- finsts_mod = mi_finsts iface
+ finsts_mod = mi_abi_finsts (mi_abi_hashes iface)
hash_env = mi_hash_fn iface
- mod_hash = mi_mod_hash iface
+ mod_hash = mi_abi_mod_hash (mi_abi_hashes iface)
imported_exports
= if not depend_on_exports
then Nothing
@@ -312,9 +312,9 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls u
Just $
HomeModImport
{ hmiu_orphanLikeHash
- = mi_orphan_like_hash iface
+ = mi_abi_orphan_like_hash (mi_abi_hashes iface)
, hmiu_importedAvails
- = moduleImportedAvails mod (mi_export_avails_hash iface) imp_decls
+ = moduleImportedAvails mod (mi_abi_export_avails_hash (mi_abi_hashes iface)) imp_decls
}
by_is_safe (ImportedByUser imv) = imv_is_safe imv
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -308,7 +308,7 @@ loadKnownKeyOccMaps
known_key_maps :: Module -> IfM lcl KnownKeyNameMaps
known_key_maps mod
= do { iface <- loadInterfaceWithException doc mod ImportBySystem
- ; let !abi_hash = mi_mod_hash iface
+ ; let !abi_hash = mi_abi_mod_hash (mi_abi_hashes iface)
; eps <- getEps
; case lookupModuleEnv (eps_known_keys eps) mod of
Just (cached_hash, kk_maps)
@@ -321,7 +321,7 @@ loadKnownKeyOccMaps
(abi_hash, kk_maps) }
; return kk_maps } }
- build_maps :: ModIface -> KnownKeyNameMaps
+ build_maps :: RetainedModIface -> KnownKeyNameMaps
build_maps iface = (kk_map, occ_map)
where
kk_map :: UniqFM KnownKey Name
@@ -628,7 +628,7 @@ loadSrcInterface :: SDoc
-> ModuleName
-> IsBootInterface -- {-# SOURCE #-} ?
-> PkgQual -- "package", if any
- -> RnM ModIface
+ -> RnM RetainedModIface
loadSrcInterface doc scope mod want_boot maybe_pkg
= do { res <- loadSrcInterface_maybe doc scope mod want_boot maybe_pkg
@@ -648,7 +648,7 @@ loadSrcInterface_maybe :: SDoc
-> ModuleName
-> IsBootInterface -- {-# SOURCE #-} ?
-> PkgQual -- "package", if any
- -> RnM (MaybeErr MissingInterfaceError ModIface)
+ -> RnM (MaybeErr MissingInterfaceError RetainedModIface)
loadSrcInterface_maybe doc scope mod want_boot maybe_pkg
-- We must first find which Module this import refers to. This involves
@@ -667,7 +667,7 @@ loadSrcInterface_maybe doc scope mod want_boot maybe_pkg
-- rare operation, but in particular it is used to load orphan modules
-- in order to pull their instances into the global package table and to
-- handle some operations in GHCi).
-loadModuleInterface :: SDoc -> Module -> TcM ModIface
+loadModuleInterface :: SDoc -> Module -> TcM RetainedModIface
loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)
-- | Load interfaces for a collection of modules.
@@ -681,7 +681,7 @@ loadModuleInterfaces doc mods
-- | Loads the interface for a given Name.
-- Should only be called for an imported name;
-- otherwise loadSysInterface may not find the interface
-loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
+loadInterfaceForName :: SDoc -> Name -> TcRn RetainedModIface
loadInterfaceForName doc name
= do { when debugIsOn $ -- Check pre-condition
do { this_mod <- getModule
@@ -690,7 +690,7 @@ loadInterfaceForName doc name
initIfaceTcRn $ loadSysInterface doc (nameModule name) }
-- | Loads the interface for a given Module.
-loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
+loadInterfaceForModule :: SDoc -> Module -> TcRn RetainedModIface
loadInterfaceForModule doc m
= do
-- Should not be called with this module
@@ -724,23 +724,23 @@ loadWiredInHomeIface name
------------------
-- | Loads a system interface and throws an exception if it fails
-loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+loadSysInterface :: SDoc -> Module -> IfM lcl RetainedModIface
loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem
------------------
-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
-- whether we should import the boot variant of the module
-loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface
+loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl RetainedModIface
loadUserInterface is_boot doc mod_name
= loadInterfaceWithException doc mod_name (ImportByUser is_boot)
-loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface
+loadPluginInterface :: SDoc -> Module -> IfM lcl RetainedModIface
loadPluginInterface doc mod_name
= loadInterfaceWithException doc mod_name ImportByPlugin
------------------
-- | A wrapper for 'loadInterface' that throws an exception if it fails
-loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
+loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl RetainedModIface
loadInterfaceWithException doc mod_name where_from
= do
dflags <- getDynFlags
@@ -749,7 +749,7 @@ loadInterfaceWithException doc mod_name where_from
------------------
loadInterface :: SDoc -> Module -> WhereFrom
- -> IfM lcl (MaybeErr MissingInterfaceError ModIface)
+ -> IfM lcl (MaybeErr MissingInterfaceError RetainedModIface)
-- loadInterface looks in both the HPT and PIT for the required interface
-- If not found, it loads it, and puts it in the PIT (always).
@@ -796,7 +796,7 @@ loadInterface doc_str mod from
liftIO $ computeInterface hsc_env doc_str hi_boot_file mod
; case read_result of {
Failed err -> do
- { let fake_iface = emptyFullModIface mod
+ { let fake_iface = shrinkModIface (emptyFullModIface mod)
; updateEps_ $ \eps ->
eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
@@ -856,16 +856,7 @@ loadInterface doc_str mod from
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; purged_hsc_env <- getTopEnv
- ; let final_iface = iface
- & set_mi_decls (panic "No mi_decls in PIT")
- & set_mi_insts (panic "No mi_insts in PIT")
- & set_mi_defaults (panic "No mi_defaults in PIT")
- & set_mi_fam_insts (panic "No mi_fam_insts in PIT")
- & set_mi_rules (panic "No mi_rules in PIT")
- & set_mi_anns (panic "No mi_anns in PIT")
- & set_mi_simplified_core (panic "No mi_simplified_core in PIT")
-
- bad_boot = mi_boot iface == IsBoot
+ ; let bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
-- Warn against an EPS-updating import
-- of one's own boot file! (one-shot only)
@@ -892,7 +883,7 @@ loadInterface doc_str mod from
then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }
else
eps {
- eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
+ eps_PIT = extendModuleEnv (eps_PIT eps) mod (shrinkModIface iface),
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps),
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
@@ -921,10 +912,8 @@ loadInterface doc_str mod from
eps_defaults = extendModuleEnv (eps_defaults eps) mod new_eps_defaults
}
- ; -- invoke plugins with *full* interface, not final_iface, to ensure
- -- that plugins have access to declarations, etc.
- res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
- ; return (Succeeded res)
+ ; res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
+ ; return (Succeeded (shrinkModIface res))
}}}}
{- Note [Loading your own hi-boot file]
=====================================
compiler/GHC/Iface/Load.hs-boot
=====================================
@@ -2,7 +2,7 @@ module GHC.Iface.Load where
import GHC.Unit.Module (Module)
import GHC.Tc.Utils.Monad (IfM)
-import GHC.Unit.Module.ModIface (ModIface)
+import GHC.Unit.Module.ModIface (RetainedModIface)
import GHC.Utils.Outputable (SDoc)
-loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+loadSysInterface :: SDoc -> Module -> IfM lcl RetainedModIface
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -707,7 +707,7 @@ checkDependencies hsc_env summary iface
return $ needsRecompileBecause $ ModulePackageChanged new_name
-needInterface :: Module -> (ModIface -> IO RecompileRequired)
+needInterface :: Module -> (RetainedModIface -> IO RecompileRequired)
-> IfG RecompileRequired
needInterface mod continue
= do
@@ -727,7 +727,7 @@ needBytecode mod continue
Nothing -> return $ NeedsRecompile MustCompile
Just mbc -> liftIO $ continue mbc
-tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
+tryGetModIface :: String -> Module -> IfG (Maybe RetainedModIface)
tryGetModIface doc_msg mod
= do -- Load the imported interface if possible
logger <- getLogger
@@ -779,7 +779,7 @@ checkModUsage _ UsagePackageModule{
logger <- getLogger
needInterface mod $ \iface -> do
let reason = ModuleChanged (moduleName mod)
- checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)
+ checkModuleFingerprint logger reason old_mod_hash (mi_abi_mod_hash (mi_abi_hashes iface))
-- We only track the ABI hash of package modules, rather than
-- individual entity usages, so if the ABI hash changes we must
-- recompile. This is safe but may entail more recompilation when
@@ -789,7 +789,7 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha
logger <- getLogger
needInterface mod $ \iface -> do
let reason = ModuleChangedRaw (moduleName mod)
- checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)
+ checkModuleFingerprint logger reason old_mod_hash (mi_abi_mod_hash (mi_abi_hashes iface))
checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name
, usg_unit_id = uid
, usg_bytecode_hash = old_bytecode_hash } = do
@@ -810,7 +810,7 @@ checkModUsage _ UsageHomeModule{
logger <- getLogger
needInterface mod $ \iface -> do
let
- new_mod_hash = mi_mod_hash iface
+ new_mod_hash = mi_abi_mod_hash (mi_abi_hashes iface)
new_decl_hash = mi_hash_fn iface
reason = ModuleChanged (moduleName mod)
@@ -864,7 +864,7 @@ checkModUsage fc UsageDirectory{ usg_dir_path = dir,
-- Does this require recompilation?
--
-- See Note [When to recompile when export lists change?]
-checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired
+checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> RetainedModIface -> IO RecompileRequired
checkHomeModImport _ _ Nothing _ = return UpToDate
checkHomeModImport logger reason
(Just (HomeModImport old_orphan_like_hash old_avails))
@@ -901,8 +901,8 @@ checkHomeModImport logger reason
2 (ppr changes)
return $ needsRecompileBecause reason
where
- new_orphan_like_hash = mi_orphan_like_hash iface
- new_avails_hash = mi_export_avails_hash iface
+ new_orphan_like_hash = mi_abi_orphan_like_hash (mi_abi_hashes iface)
+ new_avails_hash = mi_abi_export_avails_hash (mi_abi_hashes iface)
new_exports = mi_exports iface
-- | The exported avails of a module have changed. Should this cause recompilation
@@ -1617,7 +1617,7 @@ getOrphanHashes hsc_env mods = do
get_orph_hash mod = do
iface <- initIfaceLoad hsc_env . withIfaceErr ctx
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
- return (mi_orphan_hash iface)
+ return (mi_abi_orphan_hash (mi_abi_hashes iface))
mapM get_orph_hash mods
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -517,7 +517,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
-- interface, but without 'imp_mods'.
calculateAvails :: HomeUnit
-> S.Set UnitId
- -> ModIface
+ -> RetainedModIface
-> IsSafeImport
-> IsBootInterface
-> ImportedBy
@@ -525,8 +525,8 @@ calculateAvails :: HomeUnit
calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by =
let imp_mod = mi_module iface
imp_sem_mod= mi_semantic_module iface
- orph_iface = mi_orphan iface
- has_finsts = mi_finsts iface
+ orph_iface = mi_abi_orphan (mi_abi_hashes iface)
+ has_finsts = mi_abi_finsts (mi_abi_hashes iface)
deps = mi_deps iface
trust = getSafeMode $ mi_trust iface
trust_pkg = mi_trust_pkg iface
@@ -1209,7 +1209,7 @@ gresFromAvail hsc_env prov avail =
gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov)
-importsFromIface :: HscEnv -> ModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv
+importsFromIface :: HscEnv -> RetainedModIface -> ImpDeclSpec -> Maybe NameSet -> GlobalRdrEnv
importsFromIface hsc_env iface decl_spec hidden = mkGlobalRdrEnv $ case hidden of
Nothing -> all_gres
Just hidden_names -> filter (not . (`elemNameSet` hidden_names) . greName) all_gres
@@ -1225,7 +1225,7 @@ rnNamespaceSpecifier (DataNamespaceSpecifier x) = DataNamespaceSpecifier x
filterImports
:: HasDebugCallStack
=> HscEnv
- -> ModIface
+ -> RetainedModIface
-> ImpDeclSpec
-- ^ Import spec
-> Maybe (ImportListInterpretation, [LIE GhcPs])
@@ -2327,7 +2327,7 @@ getMinimalImports ie_decls
where
doc = text "Compute minimal imports for" <+> ppr decl
- to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn]
+ to_ie :: GlobalRdrEnv -> RetainedModIface -> AvailInfo -> RnM [IE GhcRn]
-- The main trick here is that if we're importing all the constructors
-- we want to say "T(..)", but if we're importing only a subset we want
-- to say "T(A,B,C)". So we have to find out what the module exports.
@@ -2529,7 +2529,7 @@ DRFPatSynExport for a test of this.
-}
badImportItemErr
- :: ModIface -> ImpDeclSpec -> IE GhcPs
+ :: RetainedModIface -> ImpDeclSpec -> IE GhcPs
-> IsSubordinateError
-> [AvailInfo]
-> TcRn (NonEmpty ImportLookupReason)
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -534,7 +534,7 @@ warnIfDeclDeprecated gre@(GRE { gre_imp = iss })
definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name)
doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
-lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
+lookupImpDeclDeprec :: RetainedModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
lookupImpDeclDeprec iface gre
-- Bleat if the thing, or its parent, is warn'd
= mi_decl_warn_fn iface (greOccName gre) `mplus`
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -190,7 +190,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
-> throwIO (InstallationError "Plugins require -fno-external-interpreter")
_ -> pure ()
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableUsage], PkgsLoaded)
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, RetainedModIface, [LinkableUsage], PkgsLoaded)
loadPlugin' occ_name plugin_name hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name occ_name
dflags = hsc_dflags hsc_env
@@ -341,7 +341,7 @@ lessUnsafeCoerce logger context what = do
-- Need the module as well to record information in the interface file
lookupRdrNameInModuleForPlugins :: HasDebugCallStack
=> HscEnv -> ModuleName -> RdrName
- -> IO (Maybe (Name, ModIface))
+ -> IO (Maybe (Name, RetainedModIface))
lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let dflags = hsc_dflags hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -6386,7 +6386,7 @@ pprImportLookup :: ImportLookupReason -> SDoc
pprImportLookup = \case
ImportLookupBad k iface decl_spec ie _exts ->
let
- pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc
+ pprImpDeclSpec :: RetainedModIface -> ImpDeclSpec -> SDoc
pprImpDeclSpec iface decl_spec =
quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of
IsBoot -> text "(hi-boot interface)"
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -215,7 +215,7 @@ import GHC.Types.DefaultEnv (ClassDefaults)
import GHC.Unit.Types (Module)
import GHC.Unit.State (UnitState)
-import GHC.Unit.Module.ModIface (ModIface)
+import GHC.Unit.Module.ModIface (RetainedModIface)
import GHC.Utils.Outputable
@@ -6635,7 +6635,7 @@ data ImportLookupReason where
T9006, T11071, T9905fail2, T5385, T10668
-}
ImportLookupBad :: BadImportKind
- -> ModIface
+ -> RetainedModIface
-> ImpDeclSpec
-> IE GhcPs
-> ImportLookupExtensions
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1693,7 +1693,7 @@ lookupArgDoc i nm = do
_ -> pure Nothing
-- | Returns the module a Name belongs to, if it is isn't local.
-getExternalModIface :: Name -> TcM (Maybe ModIface)
+getExternalModIface :: Name -> TcM (Maybe RetainedModIface)
getExternalModIface nm = do
isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm
if isLocal
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -308,7 +308,7 @@ checkFamInstConsistency directlyImpMods
ifc <- modIface mod
deps <- dep_finsts . mi_deps <$> modIface mod
pure $
- if mi_finsts ifc
+ if mi_abi_finsts (mi_abi_hashes ifc)
then mod:deps
else deps
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2964,7 +2964,7 @@ externaliseAndTidyId this_mod id
-- a package module with an interface on disk. If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
-getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
+getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe RetainedModIface)
getModuleInterface hsc_env mod
= runTcInteractive NoTcMPlugins hsc_env $
loadModuleInterface (text "getModuleInterface") mod
=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -49,7 +49,7 @@ type PackageAnnEnv = AnnEnv
type PackageCompleteMatches = CompleteMatches
-- | Helps us find information about modules in the imported packages
-type PackageIfaceTable = ModuleEnv ModIface
+type PackageIfaceTable = ModuleEnv RetainedModIface
-- Domain = modules in the imported packages
-- | Constructs an empty PackageIfaceTable
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Unit.Module.ModIface
( ModIface
@@ -68,6 +69,7 @@ module GHC.Unit.Module.ModIface
, set_mi_fix_fn
, set_mi_hash_fn
, completePartialModIface
+ , shrinkModIface
, IfaceBinHandle(..)
, PartialModIface
, RetainedModIface
@@ -82,8 +84,6 @@ module GHC.Unit.Module.ModIface
, IfaceAnnotationsData
, IfaceDeclsData
, IfaceDefaultsData
- , IfaceClsInstsData
- , IfaceFamInstsData
, IfaceRulesData
, IfaceCompleteMatchesData
, IfaceAbiHashesData
@@ -268,23 +268,13 @@ type family IfaceAnnotationsData (phase :: ModIfacePhase) where
type family IfaceDeclsData (phase :: ModIfacePhase) where
IfaceDeclsData 'ModIfaceCore = [IfaceDecl]
IfaceDeclsData 'ModIfaceFinal = [(Fingerprint, IfaceDecl)]
- IfaceDeclsData 'ModIfaceRetained = ()
+ IfaceDeclsData 'ModIfaceRetained = [IfaceDecl]
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]
@@ -413,9 +403,9 @@ data IfacePublic_ phase = IfacePublic {
-- Instance declarations and rules
- mi_insts_ :: IfaceClsInstsData phase, -- ^ Sorted class instance
- mi_fam_insts_ :: IfaceFamInstsData phase, -- ^ Sorted family instances
- mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules
+ mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance
+ mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances
+ mi_rules_ :: IfaceRulesData phase, -- ^ Sorted rules
mi_trust_ :: IfaceTrustInfo,
@@ -608,7 +598,7 @@ mi_orphan_hash iface = mi_abi_orphan_hash (mi_abi_hashes iface)
-- | Old-style accessor for whether or not the ModIface came from an hs-boot
-- file.
-mi_boot :: ModIface -> IsBootInterface
+mi_boot :: ModIface_ phase -> IsBootInterface
mi_boot iface = if mi_hsc_src iface == HsBootFile
then IsBoot
else NotBoot
@@ -618,7 +608,7 @@ mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface)
-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
-- found, 'defaultFixity' is returned instead.
-mi_fix :: ModIface -> OccName -> Fixity
+mi_fix :: ModIface_ phase -> OccName -> Fixity
mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity
-- | The semantic module for this interface; e.g., if it's a interface
@@ -634,7 +624,7 @@ mi_semantic_module iface = mi_mod_info_semantic_module (mi_mod_info iface)
-- | The "precise" free holes, e.g., the signatures that this
-- 'ModIface' depends on.
-mi_free_holes :: ModIface -> UniqDSet ModuleName
+mi_free_holes :: ModIface_ phase -> UniqDSet ModuleName
mi_free_holes iface =
case getModuleInstantiation (mi_module iface) of
(_, Just indef)
@@ -851,8 +841,8 @@ emptyIfaceModInfo mod = IfaceModInfo
emptyPublicModIface :: IfaceAnnotationsData phase
-> IfaceDeclsData phase
-> IfaceDefaultsData phase
- -> IfaceClsInstsData phase
- -> IfaceFamInstsData phase
+ -> [IfaceClsInst]
+ -> [IfaceFamInst]
-> IfaceRulesData phase
-> IfaceCompleteMatchesData phase
-> IfaceAbiHashesData phase
@@ -930,8 +920,6 @@ 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)
@@ -970,8 +958,6 @@ 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)
@@ -1051,7 +1037,6 @@ completePartialModIface partial iface_hash decls extra_decls final_exts cache =
, mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing
, mi_iface_hash_ = iface_hash
}
- where
-- | Given a 'PartialIfacePublic', turn it into an 'IfacePublic' by completing
-- missing fields.
@@ -1066,6 +1051,30 @@ completePublicModIface decls abi_hashes cache partial = partial
, mi_caches_ = cache
}
+shrinkModIface :: ModIface -> RetainedModIface
+shrinkModIface PrivateModIface {..}
+ = PrivateModIface
+ {
+ mi_hi_bytes_ = RetainedIfaceBinHandle,
+ mi_public_ = shrinkIfacePublic mi_public_,
+ mi_self_recomp_ = (),
+ mi_simplified_core_ = (),
+ mi_ext_fields_ = (),
+ ..
+ }
+
+shrinkIfacePublic :: IfacePublic -> RetainedIfacePublic
+shrinkIfacePublic IfacePublic {..}
+ = IfacePublic
+ {
+ mi_anns_ = (),
+ mi_decls_ = map snd mi_decls_,
+ mi_defaults_ = (),
+ mi_rules_ = (),
+ mi_complete_matches_ = (),
+ ..
+ }
+
set_mi_mod_info :: IfaceModInfo -> ModIface_ phase -> ModIface_ phase
set_mi_mod_info val iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = val }
@@ -1107,10 +1116,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 :: IfaceClsInstsData phase -> ModIface_ phase -> ModIface_ phase
+set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase
set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val })
-set_mi_fam_insts :: IfaceFamInstsData phase -> ModIface_ phase -> ModIface_ phase
+set_mi_fam_insts :: [IfaceFamInst] -> 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
@@ -1282,8 +1291,8 @@ pattern ModIface ::
-> IfaceSimplifiedCoreData phase
-> IfaceDefaultsData phase
-> IfaceTopEnv
- -> IfaceClsInstsData phase
- -> IfaceFamInstsData phase
+ -> [IfaceClsInst]
+ -> [IfaceFamInst]
-> IfaceRulesData phase
-> IfaceTrustInfo
-> Bool
=====================================
ghc/Main.hs
=====================================
@@ -515,7 +515,7 @@ abiHash strs = do
put_ bh hiVersion
-- package hashes change when the compiler version changes (for now)
-- see #5328
- mapM_ (put_ bh . mi_mod_hash) ifaces
+ mapM_ (put_ bh . mi_abi_mod_hash . mi_abi_hashes) ifaces
f <- fingerprintBinMem bh
putStrLn (showPpr dflags f)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -74,7 +74,7 @@ import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
import GHC.Unit.Module.Graph (ModuleGraphNode (..), ModuleNodeInfo(..))
import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.ModIface (mi_semantic_module, mi_boot)
+import GHC.Unit.Module.ModIface (RetainedModIface, shrinkModIface, mi_semantic_module, mi_boot)
import GHC.Unit.Module.ModSummary (isBootSummary)
import GHC.Utils.Outputable (Outputable, (<+>), pprModuleName, text)
import GHC.Utils.Error (withTiming)
@@ -254,7 +254,7 @@ dropErr :: MaybeErr e a -> Maybe a
dropErr (Succeeded a) = Just a
dropErr (Failed _) = Nothing
-loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (ModIface, ([ClsInst], [FamInst]))
+loadHiFile :: HscEnv -> Outputable.SDoc -> Module -> IO (RetainedModIface, ([ClsInst], [FamInst]))
loadHiFile hsc_env doc theModule = initIfaceLoad hsc_env $ do
mod_iface <- loadSysInterface doc theModule
@@ -288,7 +288,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 (hm_iface hmi, (cls_insts, fam_insts))
+ pure (shrinkModIface (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
- -> ModIface
+ -> RetainedModIface
-> IfaceMap
-> InstIfaceMap
-> ([ClsInst], [FamInst])
@@ -105,7 +105,7 @@ createInterface1'
-> UnitState
-> DynFlags
-> FilePath
- -> ModIface
+ -> RetainedModIface
-> 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/-/commit/260b75fcb25d56ba552159637ef7005…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/260b75fcb25d56ba552159637ef7005…
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