Simon Peyton Jones pushed to branch wip/T27828 at Glasgow Haskell Compiler / GHC
Commits:
b9431ef2 by Simon Peyton Jones at 2026-09-24T15:42:33+01:00
Add cab_overlaps
Needs some documentation; fixes bug discovered by Fable
- - - - -
8 changed files:
- changelog.d/T27828
- compiler/GHC/Builtin/WiredIn/Types/Box.hs
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/TyCl.hs
- testsuite/tests/indexed-types/should_compile/all.T
Changes:
=====================================
changelog.d/T27828
=====================================
@@ -4,5 +4,5 @@ issues: #27828
mrs: !16714
description: {
- There was a bug in the implemenation of functional dependencies for type families.
+ There was a bug in the implementation of functional dependencies for type families.
}
=====================================
compiler/GHC/Builtin/WiredIn/Types/Box.hs
=====================================
@@ -329,7 +329,8 @@ mkWiredInNewTyCon tc_name dc_name nt_co_uniq bndrs roles nt_fld_ty =
, cab_roles = roles
, cab_lhs = mkTyVarTys tvs
, cab_rhs = nt_fld_ty
- , cab_incomps = [] }
+ , cab_overlaps = []
+ , cab_incomps = [] }
-- | The wired-in @Box@ newtype:
--
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Core.Coercion.Axiom (
coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars,
coAxBranchRoles,
coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
- placeHolderIncomps,
+ placeHolderIncomps, placeHolderOverlaps,
Role(..),
@@ -275,8 +275,15 @@ data CoAxBranch
, cab_rhs :: Type
-- ^ Right-hand side of the equality
-- See Note [CoAxioms are homogeneous]
+
+ , cab_overlaps :: [CoAxBranch]
+ -- ^ The preceding branches whose LHSs are /unify with/ this one
+ -- Order is unimportant
+ -- See Note [Storing compatibility]
+
, cab_incomps :: [CoAxBranch]
- -- ^ The previous incompatible branches
+ -- ^ The preceding branches that are /incompatible/ with this one
+ -- Order is unimportant
-- See Note [Storing compatibility]
}
deriving Data.Data
@@ -349,8 +356,9 @@ coAxBranchIncomps :: CoAxBranch -> [CoAxBranch]
coAxBranchIncomps = cab_incomps
-- See Note [Compatibility] in GHC.Core.FamInstEnv
-placeHolderIncomps :: [CoAxBranch]
-placeHolderIncomps = panic "placeHolderIncomps"
+placeHolderIncomps, placeHolderOverlaps :: [CoAxBranch]
+placeHolderIncomps = panic "placeHolderIncomps"
+placeHolderOverlaps = panic "placeHolderOverlaps"
{-
Note [CoAxBranch type variables]
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -487,22 +487,45 @@ in GHC.Core.Unify.)
Note [Compatibility]
~~~~~~~~~~~~~~~~~~~~
-Two patterns are /compatible/ if either of the following conditions hold:
+Consider a closed type family with two equations (X1) and (X2)
+ type family F a where
+ F lhs1 = rhs1 -- (X1)
+ ...
+ F lhs2 = rhs2 -- (X2)
+ ...
+Then equations (X1) and (X2) are /compatible/ if any target (F ty) that
+matches both equations yields the very same right hand side. Example:
+ And True True = True
+ And a True = a
+The target (And True True) matches both equations but they then both
+produce the same reduct True.
+
+More precisely (X1) and (X2) are /compatible/ iff
+ If LHSs unify with a substitution S, then S(rhs1) = S(rhs2)
+
+Conversely, (X1) and (X2) are /incompatible/ if
+ Their LHSs unify with S, and S(rhs1) /= S(rhs2)
- 1) The patterns are apart.
+For open type families, only compatible instances are allowed. For closed
+families, we use the Closed Family Matching Rule (see function `findBranch`):
- 2) The patterns unify with a substitution S, and their right hand sides
- are equal under that substitution.
+ When looking up a target (F ty) in a closed type family F,
+ find an equation (branch) such that:
+ * the LHS matches the target
+ * the target is apart from every previous /incompatible/ equation for F
-For open type families, only compatible instances are allowed. For closed
-type families, the story is slightly more complicated. Consider the following:
+We don't need to check the earlier equations that are compatible with the
+matching equation, because they are either irrelevant (clause 1 of compatible)
+or benign (clause 2 of compatible).
+
+Some examples:
-type family F a where
- F Int = Bool
- F a = Int
+ type family F a where
+ F Int = Bool
+ F a = Int
-g :: Show a => a -> F a
-g x = length (show x)
+ g :: Show a => a -> F a
+ g x = length (show x)
Should that type-check? No. We need to allow for the possibility that 'a'
might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int
@@ -518,12 +541,12 @@ potentially-overlapping group is closed.
As another example, consider this:
-type family G x where
- G Int = Bool
- G a = Double
+ type family G x where
+ G Int = Bool
+ G a = Double
-type family H y
--- no instances
+ type family H y
+ -- no instances
Now, we want to simplify (G (H Char)). We can't, because (H Char) might later
simplify to be Int. So, (G (H Char)) is stuck, for now.
@@ -531,18 +554,13 @@ simplify to be Int. So, (G (H Char)) is stuck, for now.
While everything above is quite sound, it isn't as expressive as we'd like.
Consider this:
-type family J a where
- J Int = Int
- J a = a
+ type family J a where
+ J Int = Int
+ J a = a
Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if
b is instantiated with Int, but the RHSs coincide there, so it's all OK.
-
-So, the rule is this: when looking up a branch in a closed type family, we
-find a branch that matches the target, but then we make sure that the target
-is apart from every previous *incompatible* branch. We don't check the
-branches that are compatible with the matching branch, because they are either
-irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).
+Hence the Closed Family Matching Rule.
Note [Compatibility of eta-reduced axioms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -574,15 +592,30 @@ fails anyway.
-- See Note [Compatibility]
compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool
-compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })
- (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })
+compatibleBranches b1 b2
+ = case compareBranches b1 b2 of
+ BC_Apart -> True
+ BC_Compat -> True
+ BC_Incompat -> False
+
+data BranchCompatibility
+ = BC_Apart -- LHSs are apart
+ | BC_Compat -- LHSs unify with S, and S(rhs1)=S(rhs2)
+ | BC_Incompat -- LHSs unify with S, and S(rhs1)/=S(rhs2)
+
+compareBranches :: CoAxBranch -> CoAxBranch -> BranchCompatibility
+compareBranches b1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })
+ b2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })
= case tcUnifyTysFG alwaysBindFam alwaysBindTv commonlhs1 commonlhs2 of
-- Here we need the cab_tvs of the two branches to be disinct.
-- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom.
- SurelyApart -> True
- MaybeApart {} -> False
- Unifiable subst -> Type.substTyAddInScope subst rhs1 `eqType`
+ SurelyApart -> BC_Apart
+ MaybeApart {} -> pprPanic "compareBranches" (ppr b1 $$ ppr b2)
+ Unifiable subst | Type.substTyAddInScope subst rhs1 `eqType`
Type.substTyAddInScope subst rhs2
+ -> BC_Compat
+ | otherwise
+ -> BC_Incompat
where
(commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2
-- See Note [Compatibility of eta-reduced axioms]
@@ -630,10 +663,10 @@ injectiveBranches injectivity
lhs1Subst = Type.substTys subst (getInjArgs lhs1)
lhs2Subst = Type.substTys subst (getInjArgs lhs2)
--- takes a CoAxiom with unknown branch incompatibilities and computes
--- the compatibilities
--- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom
computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch]
+-- Takes a CoAxiom for a closed type family with place-holder
+-- `cab_incomps` and `cab_overlaps` fields, and computes those fields
+-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom
computeAxiomIncomps branches
= snd (mapAccumL go [] branches)
where
@@ -641,11 +674,23 @@ computeAxiomIncomps branches
go prev_brs cur_br
= (new_br : prev_brs, new_br)
where
- new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br }
-
- mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch]
- mk_incomps prev_brs cur_br
- = filter (not . compatibleBranches cur_br) prev_brs
+ (overlaps,incomps) = get_cab [] [] prev_brs
+ new_br = cur_br { cab_overlaps = overlaps, cab_incomps = incomps }
+
+ get_cab :: [CoAxBranch] -> [CoAxBranch] -- Accumulators
+ -> [CoAxBranch]
+ -> ([CoAxBranch], [CoAxBranch])
+ get_cab overlaps incomps [] = (overlaps,incomps)
+ get_cab overlaps incomps (br:brs)
+ = case compareBranches cur_br br of
+ BC_Apart -> get_cab overlaps incomps brs
+ BC_Compat -> get_cab (br:overlaps) incomps brs
+ BC_Incompat -> get_cab (br:overlaps) (br:incomps) brs
+
+noAxiomIncomps :: CoAxBranch -> CoAxBranch
+-- Overwrite the placeholders for `cab_incomps` and `cab_overlaps`
+-- with [], because unbranched axioms have no "preceding" equations
+noAxiomIncomps branch = branch { cab_incomps = [], cab_overlaps = [] }
{-
************************************************************************
@@ -716,14 +761,15 @@ mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars
-> SrcSpan
-> CoAxBranch
mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc
- = CoAxBranch { cab_tvs = tvs'
- , cab_eta_tvs = eta_tvs'
- , cab_cvs = cvs'
- , cab_lhs = tidyTypes env lhs
- , cab_roles = roles
- , cab_rhs = tidyType env rhs
- , cab_loc = loc
- , cab_incomps = placeHolderIncomps }
+ = CoAxBranch { cab_tvs = tvs'
+ , cab_eta_tvs = eta_tvs'
+ , cab_cvs = cvs'
+ , cab_lhs = tidyTypes env lhs
+ , cab_roles = roles
+ , cab_rhs = tidyType env rhs
+ , cab_loc = loc
+ , cab_overlaps = placeHolderOverlaps
+ , cab_incomps = placeHolderIncomps }
where
(env1, tvs') = tidyVarBndrs init_tidy_env tvs
(env2, eta_tvs') = tidyVarBndrs env1 eta_tvs
@@ -737,12 +783,12 @@ mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc
-- all of the following code is here to avoid mutual dependencies with
-- Coercion
-mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched
-mkBranchedCoAxiom ax_name fam_tc branches
+mkBranchedCoAxiom :: Role -> Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched
+mkBranchedCoAxiom role ax_name fam_tc branches
= CoAxiom { co_ax_unique = nameUnique ax_name
, co_ax_name = ax_name
, co_ax_tc = fam_tc
- , co_ax_role = Nominal
+ , co_ax_role = role
, co_ax_implicit = False
, co_ax_branches = manyBranches (computeAxiomIncomps branches) }
@@ -753,7 +799,7 @@ mkUnbranchedCoAxiom ax_name fam_tc branch
, co_ax_tc = fam_tc
, co_ax_role = Nominal
, co_ax_implicit = False
- , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
+ , co_ax_branches = unbranched (noAxiomIncomps branch) }
mkSingleCoAxiom :: Role -> Name
-> [TyVar] -> [TyVar] -> [CoVar]
@@ -768,7 +814,7 @@ mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty
, co_ax_tc = fam_tc
, co_ax_role = role
, co_ax_implicit = False
- , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
+ , co_ax_branches = unbranched (noAxiomIncomps branch) }
where
branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty
(map (const Nominal) tvs)
@@ -786,7 +832,7 @@ mkNewTypeCoAxiom name tycon tvs roles rhs_ty
, co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon
, co_ax_role = Representational
, co_ax_tc = tycon
- , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
+ , co_ax_branches = unbranched (noAxiomIncomps branch) }
where
branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty
roles (getSrcSpan name)
@@ -1224,7 +1270,9 @@ findBranch :: Array BranchIndex CoAxBranch
-> Maybe (BranchIndex, [Type], [Coercion])
-- coercions relate requested types to returned axiom LHS at role N
findBranch branches target_tys
- = foldr go Nothing (assocs branches)
+ = -- Implements the Closed Family Matching Rule
+ -- in Note [Compatibility]
+ foldr go Nothing (assocs branches)
where
go :: (BranchIndex, CoAxBranch)
-> Maybe (BranchIndex, [Type], [Coercion])
@@ -1264,8 +1312,8 @@ noEarlierMatchCheck
:: [Type]
-> CoAxBranch -- ^ The candidate equation we wish to use
-> Bool -- ^ True <=> equation can fire
-noEarlierMatchCheck target (CoAxBranch { cab_incomps = incomps })
- = not (any matches incomps)
+noEarlierMatchCheck target (CoAxBranch { cab_overlaps = overlaps })
+ = not (any matches overlaps)
where
matches earlier_branch
= isJust (tcMatchTys (coAxBranchLHS earlier_branch) target)
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -903,12 +903,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
-- See #13803
; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
$ tc_ax_branches branches
- ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
- , co_ax_name = tc_name
- , co_ax_tc = tc_tycon
- , co_ax_role = role
- , co_ax_branches = manyBranches tc_branches
- , co_ax_implicit = False }
+ ; let axiom = mkBranchedCoAxiom role tc_name tc_tycon tc_branches
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = name
@@ -1124,7 +1119,7 @@ tc_ax_branch prev_branches
, ifaxbEtaTyVars = eta_tv_bndrs
, ifaxbCoVars = cv_bndrs
, ifaxbLHS = lhs, ifaxbRHS = rhs
- , ifaxbRoles = roles, ifaxbIncomps = incomps })
+ , ifaxbRoles = roles, ifaxbIncomps = _incomps })
= bindIfaceTyConBinders_AT
(map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom
@@ -1135,14 +1130,15 @@ tc_ax_branch prev_branches
; this_mod <- getIfModule
; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`
moduleNameFS (moduleName this_mod))
- br = CoAxBranch { cab_loc = loc
- , cab_tvs = binderVars tvs
- , cab_eta_tvs = eta_tvs
- , cab_cvs = cvs
- , cab_lhs = tc_lhs
- , cab_roles = roles
- , cab_rhs = tc_rhs
- , cab_incomps = map (prev_branches `getNth`) incomps }
+ br = CoAxBranch { cab_loc = loc
+ , cab_tvs = binderVars tvs
+ , cab_eta_tvs = eta_tvs
+ , cab_cvs = cvs
+ , cab_lhs = tc_lhs
+ , cab_roles = roles
+ , cab_rhs = tc_rhs
+ , cab_overlaps = placeHolderOverlaps
+ , cab_incomps = placeHolderIncomps }
; return (prev_branches ++ [br]) }
tcIfaceDataCons :: Name -> TyCon -> IfaceConDecls -> IfL AlgTyConRhs
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -1047,7 +1047,7 @@ Note [Exploiting closed type families].
You might think that (B3) could be instantiated to Bak Char ~ Char; but
actually that instantiation will never fire because (B2) Bak Char ~ Int would
fire first. So the only way to return a Char is via (B1); so we
- can emit [W] alpha ~ Int. Hence (B3) is not relevant; only (B2) is relevant.
+ can emit [W] alpha ~ Int. Hence (B3) is not relevant; only (B1) is relevant.
That is the reason for condition (R2) in the definition of Relevance above.
A watertight proof that this is the Right Thing is not very easy. See more
@@ -1072,6 +1072,23 @@ Note [Exploiting closed type families].
TMessage @SC @Req alpha
and equation (T1) does not match that. (It does unify, but we don't care.)
+(RW5) `noEarlierMatchCheck`: in (RW4) We really do need to check that /no/
+ earlier equation matches, not just no earlier /incompatible/ equation
+ matches. Consider T27282a:
+ type family F a where
+ F Int = Int -- B1
+ F Char = Bool -- B2
+ F a = a -- B3
+
+ [W] F alpha ~ Int
+
+ (B1) is relevant, and (B2) is not. What about (B3)? It pre-unifies with
+ the Wanted via [alpha :-> Int, a :-> Int]. But under that substitution
+ (B1) would fire, so (B3) is not relevant.
+
+ And yet, (B1) is /compatible/ with (B3), so it's no good just looking at
+ the `cab_incomps` of (B3). Instead we look at `cab_overlaps`.
+
Note [Exploiting open type families] see `mkTopOpenFamEqFDs`
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generating fundeps from a top-level type instance is covered in Section 5.2 in
@@ -1451,6 +1468,8 @@ solveFunDeps work_ev fd_eqns
; uPairsTcM uenv eqs }
instantiateFunDepEqns :: FunDepEqns -> TcM [TypeEqn]
+-- See GHC.Tc.Instance.Fundeps Note [Improving against instances]
+-- Wrinkle (IMP1)
instantiateFunDepEqns (FDEqns { fd_qtvs = qtvs, fd_eqs = eqs })
| null qtvs
= return rev_eqs
@@ -1463,11 +1482,9 @@ instantiateFunDepEqns (FDEqns { fd_qtvs = qtvs, fd_eqs = eqs })
-- (reverse eqs): See Note [Reverse order of fundep equations]
subst_pair subst (Pair ty1 ty2)
- = Pair (substTy subst' ty1) (substTy subst' ty2)
--- ToDo not correct!
+ = Pair (substTy subst' ty1) ty2
-- ty2 does not mention fd_qtvs, so no need to subst it.
- -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]
- -- Wrinkle (IMP1)
+ -- See invariant on `fv_eqs` in `data FunDepEqns`.
where
subst' = extendSubstInScopeSet subst (tyCoVarsOfTypes [ty1,ty2])
-- The free vars of ty1 aren't just fd_qtvs: ty1 is the result
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3462,7 +3462,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
; let mb_co_ax
| null eqns = Nothing -- mkBranchedCoAxiom fails on empty list
- | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
+ | otherwise = Just (mkBranchedCoAxiom Nominal co_ax_name fam_tc branches)
fam_tc = mkFamilyTyCon tc_name kind tc_bndrs 0 res_kind (resultVariableName sig)
(ClosedTypeFamilyTyCon $ CTF mb_co_ax) parent inj'
=====================================
testsuite/tests/indexed-types/should_compile/all.T
=====================================
@@ -317,3 +317,4 @@ test('T25611c', normal, compile, [''])
test('T25611d', normal, compile, [''])
test('T25657', normal, compile, [''])
test('T27828', normal, compile, [''])
+test('T27828a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9431ef21af13163fdfde045cd1f500…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9431ef21af13163fdfde045cd1f500…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/sjakobi/absent-filler-note
by Simon Jakobi (＠sjakobi) 24 Sep '26
by Simon Jakobi (＠sjakobi) 24 Sep '26
24 Sep '26
Simon Jakobi pushed new branch wip/sjakobi/absent-filler-note at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/absent-filler-note
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] 3 commits: Refactor Makefile to use phases appropriately
by Hannes Siebenhandl (＠fendor) 24 Sep '26
by Hannes Siebenhandl (＠fendor) 24 Sep '26
24 Sep '26
Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC
Commits:
776eb729 by fendor at 2026-09-24T14:54:13+02:00
Refactor Makefile to use phases appropriately
Prepare refactoring to allow json and Makefile implementation
- - - - -
ba42becc by fendor at 2026-09-24T14:54:15+02:00
Abstract dependency processing from Makefile generation
Allows multiple consumers
- - - - -
020bc06b by fendor at 2026-09-24T14:54:15+02:00
Add json output format
- - - - -
10 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/tests/driver/T24384/Makefile
- + testsuite/tests/driver/T24384/T24384b.stdout
- testsuite/tests/driver/T24384/all.T
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
- -- If -ddump-mod-cycles, show cycles in the module graph
- liftIO $ dumpModCycles logger module_graph
+ -- 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
+
+ -- 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 :: Module
+ , dn_src :: OsPath
+ , dn_obj :: OsPath
+ , dn_hi :: OsPath
+ , dn_boot :: IsBootInterface
+ , 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_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 = ms_mod node
+ , dn_src = src_file
+ , dn_obj = msObjFileOsPath node
+ , dn_hi = msHiFileOsPath node
+ , dn_boot = isBootSummary 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
+ }
+
+ 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,55 @@ 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
+ | IsBoot <- dn_boot
+ = [([obj], hi) | (obj, hi) <- zip (suffixed (removeBootSuffix dn_obj)) (suffixed dn_hi)]
+ | otherwise
+ = []
+
+ -- 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
-
- -- 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)
+ | otherwise
+ -> []
- ; (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)
+ DepCpp {dep_path} -> [(obj_files, dep_path)]
- ; 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))
- }
+ write (from, to) = writeDependency root hdl from to
-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)))
+ obj_files = suffixed dn_obj
- -- Not in this package: we don't need a dependency
- | otherwise
- -> return (Right Nothing)
+ suffixed f = insertSuffixes f suffixes
- 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_boot} = 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 +493,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 +545,186 @@ 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 PackageDeps
+ = PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName))
+ 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
+ , modules :: (Set.Set ModuleName, Set.Set ModuleName)
+ , packages :: PackageDeps
+ , cpp :: Set.Set OsPath
+ , options :: [String]
+ , preprocessor :: Maybe FilePath
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically Deps)
+
+newtype DepJson = DepJson (Map.Map ModuleName Deps)
+
+instance ToJson DepJson where
+ json (DepJson m) =
+ JSObject [
+ (moduleNameString target, JSObject [
+ ("sources", array sources (showOsPath . normalise)),
+ ("modules", array (fst modules) moduleNameString),
+ ("modules-boot", array (snd modules) moduleNameString),
+ ("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),
+ ("options", JSArray $ map JSString options),
+ ("preprocessor", maybe JSNull JSString preprocessor)
+ ])
+ | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m
+ ]
+ where
+ package name unit_id (PackageId package_id) mods =
+ JSObject [
+ ("id", JSString (unitIdString unit_id)),
+ ("name", JSString name),
+ ("package-id", JSString (unpackFS package_id)),
+ ("modules", array mods moduleNameString)
+ ]
+
+ array values render = JSArray (fmap (JSString . render) (Set.toList values))
+
+ showOsPath = unsafeDecodeUtf
+
+initDepJson :: IO (IORef DepJson)
+initDepJson = newIORef $ DepJson Map.empty
+
+insertDepJson :: [ModuleName] -> Deps -> DepJson -> DepJson
+insertDepJson targets dep (DepJson m0) =
+ DepJson
+ $ foldl'
+ ( \acc target ->
+ Map.insertWith
+ (Semigroup.<>)
+ target
+ dep
+ acc
+ )
+ m0
+ targets
+
+updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
+updateDepJson include_pkgs DepNode {..} deps =
+ insertDepJson [moduleName dn_mod] payload
+ where
+ payload = node_data Semigroup.<> foldMap dep deps
+
+ node_data =
+ mempty {
+ sources = Set.singleton dn_src,
+ preprocessor = pn_preprocessor dn_preprocessing,
+ options = pn_options dn_preprocessing
+ }
+
+ dep = \case
+ DepHi {dep_mod, dep_local, dep_unit, dep_boot}
+ | dep_local
+ , let set = Set.singleton $ moduleName dep_mod
+ value | IsBoot <- dep_boot = (Set.empty, set)
+ | otherwise = (set, Set.empty)
+ -> mempty {modules = value}
+
+ | 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)
+ key = (lname, unitId unit, DPackageId $ unitPackageId unit)
+ -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton $ moduleName dep_mod))}
+
+ | otherwise
+ -> mempty
+
+ DepCpp {dep_path} ->
+ mempty {cpp = Set.singleton dep_path}
+
-----------------------------------------------------------------
-- 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/tests/driver/T24384/Makefile
=====================================
@@ -38,3 +38,11 @@ T24384a: T24384_prep
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 | jq --sort-keys
=====================================
testsuite/tests/driver/T24384/T24384b.stdout
=====================================
@@ -0,0 +1,157 @@
+{
+ "A": {
+ "cpp": [],
+ "modules": [],
+ "modules-boot": [
+ "C"
+ ],
+ "options": [
+ "-XStrict",
+ "-fexpose-all-unfoldings"
+ ],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "A.hs"
+ ]
+ },
+ "B": {
+ "cpp": [],
+ "modules": [
+ "A"
+ ],
+ "modules-boot": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ }
+ ],
+ "preprocessor": "./preproc.sh",
+ "sources": [
+ "lib/B.hs"
+ ]
+ },
+ "C": {
+ "cpp": [],
+ "modules": [
+ "A",
+ "E"
+ ],
+ "modules-boot": [],
+ "options": [],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ },
+ {
+ "id": "containers-0.8-inplace",
+ "modules": [
+ "Data.Set"
+ ],
+ "name": "containers",
+ "package-id": "containers-0.8"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "C.hs",
+ "C.hs-boot"
+ ]
+ },
+ "D": {
+ "cpp": [],
+ "modules": [
+ "B",
+ "C"
+ ],
+ "modules-boot": [],
+ "options": [],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "D.hs"
+ ]
+ },
+ "E": {
+ "cpp": [],
+ "modules": [],
+ "modules-boot": [],
+ "options": [],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ },
+ {
+ "id": "dep-1-XXX",
+ "modules": [
+ "Dep"
+ ],
+ "name": "dep",
+ "package-id": "dep-1"
+ },
+ {
+ "id": "dep-public-1-XXX",
+ "modules": [
+ "DepPublic"
+ ],
+ "name": "dep-public",
+ "package-id": "dep-public-1"
+ },
+ {
+ "id": "template-haskell-2.25.0.0-inplace",
+ "modules": [
+ "Language.Haskell.TH.Syntax"
+ ],
+ "name": "template-haskell",
+ "package-id": "template-haskell-2.25.0.0"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "E.hs"
+ ]
+ }
+}
=====================================
testsuite/tests/driver/T24384/all.T
=====================================
@@ -5,3 +5,4 @@ test_extras = extra_files(
])
test('T24384a', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, [])
+test('T24384b', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, [])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a20c20326d9f7672efb0114b0359e3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a20c20326d9f7672efb0114b0359e3…
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] 10 commits: Remove the call to hoistFlag from processCmdLineP
by Hannes Siebenhandl (＠fendor) 24 Sep '26
by Hannes Siebenhandl (＠fendor) 24 Sep '26
24 Sep '26
Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC
Commits:
098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00
Remove the call to hoistFlag from processCmdLineP
This call was undesirable because it was causing a reconstruction
of the list of flag processors.
Even relying on list fusion would not be sufficient because we want
to replace the list with a data structure with faster lookups to
address #25763.
The removal is done in two moves:
* We move CmdLineP to CmdLine.hs
* Then we move the effect of hoisting to processArgs via a new function
hoistEwM
- - - - -
e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00
Do not create duplicate flag processors for the -W flag
This makes simpler implementing the command line parser with a trie map
holding flag processors. If we were to allow duplicate flag processors
for any flag, the trie map would need to be a multimap.
- - - - -
3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00
Replace the list of flag processors with a trie map in `processArgs`
Previously `GHC.Driver.CmdLine.findArg` was called for each
command-line argument, doing a linear search on the list of flag
processors each time. This was somewhat costly as the list of flag
processor has near 2000 elements.
A lookup with a trie map is faster in general, but the speed up is
only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient
times, so the amount of lookups piles up. This could happen in large
projects with many units each having many dependencies. If only a
module needs to be recompiled, the user still needs to wait for all of
the flag parsing to complete.
The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a
10x speed up when using the trie.
The trie map is implemented in `GHC.Data.StringTrie`.
The design is explained in Note [Processing command line argument fast]
in GHC.Driver.Session.
The commit also:
* adds two property-based tests for trie map operations,
* adds a benchmark of the command line parser, and
* renames the predicate `arg_ok` to `valid_flag_suffix` to decide what
flag processor should be used when there are multiple matching
prefixes on a flag.
Fixes #25763.
- - - - -
5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00
Compile Word64{Map,Set} with -O2 always.
This is the hottest code and even if we build GHC with -O0 otherwise -O2
pays off for these modules.
Fixes #27814.
- - - - -
545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00
Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types
bitReverse{16,32}# and byteSwap{16,32}# have the type
Word# -> Word#, but their C correspondents took and
returned StgWord{16,32}.
The mismatch on bitReverse16# led to the problem reported
in #27299. Although no similar issue is reported for
bitReverse32# and byteSwap{16,32}#, it seemed wise to
change them proactively.
This commit fixes the mismatch by changing the C type.
Fixes #27299
- - - - -
bf17f289 by fendor at 2026-09-22T15:04:05-04:00
Don't lose instances from shadowed imported modules with the same name
When we look for instances below the current module, we need to check
the unit id as well when we check for whether the module is the current
module, otherwise we ignore modules we import that have the same name as
the import module.
Adds regression test.
- - - - -
9c2c7652 by fendor at 2026-09-24T14:21:38+02:00
Add makefile -M test
- - - - -
bf4a05a9 by fendor at 2026-09-24T14:21:38+02:00
Refactor Makefile to use phases appropriately
Prepare refactoring to allow json and Makefile implementation
- - - - -
ebde81ac by fendor at 2026-09-24T14:21:38+02:00
Abstract dependency processing from Makefile generation
Allows multiple consumers
- - - - -
a20c2032 by fendor at 2026-09-24T14:21:38+02:00
Add json output format
- - - - -
55 changed files:
- + changelog.d/25763-cmdline-opt
- + changelog.d/26610
- + compiler/GHC/Data/StringTrie.hs
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Strict/Internal.hs
- compiler/GHC/Data/Word64Set/Internal.hs
- compiler/GHC/Driver/CmdLine.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Env.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
- compiler/ghc.cabal.in
- docs/users_guide/separate_compilation.rst
- ghc/GHC/Driver/Session/Mode.hs
- rts/include/stg/Prim.h
- rts/prim/bitrev.c
- rts/prim/bswap.c
- testsuite/tests/MiniQuickCheck.hs
- + 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/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/lib/B.hs
- + testsuite/tests/driver/T24384/preproc.sh
- testsuite/tests/driver/all.T
- + testsuite/tests/driver/stringtrie.hs
- + testsuite/tests/driver/stringtrie.stdout
- + testsuite/tests/ghci/prog-mhu008/Makefile
- + testsuite/tests/ghci/prog-mhu008/a/M.hs
- + testsuite/tests/ghci/prog-mhu008/all.T
- + testsuite/tests/ghci/prog-mhu008/b/M.hs
- + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script
- + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout
- + testsuite/tests/ghci/prog-mhu008/unitA
- + testsuite/tests/ghci/prog-mhu008/unitB
- + testsuite/tests/perf/compiler/T25763.stderr
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/primops/should_run/T27299.hs
- + testsuite/tests/primops/should_run/T27299.stdout
- testsuite/tests/primops/should_run/all.T
- + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr
- testsuite/tests/warnings/should_fail/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13dd8d668f93306b61a9ec48066866…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13dd8d668f93306b61a9ec48066866…
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] 4 commits: Add makefile -M test
by Hannes Siebenhandl (＠fendor) 24 Sep '26
by Hannes Siebenhandl (＠fendor) 24 Sep '26
24 Sep '26
Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC
Commits:
217a0cf4 by fendor at 2026-09-24T14:05:24+02:00
Add makefile -M test
- - - - -
f9995341 by fendor at 2026-09-24T14:05:35+02:00
Refactor Makefile to use phases appropriately
Prepare refactoring to allow json and Makefile implementation
- - - - -
e0a1ccae by fendor at 2026-09-24T14:05:35+02:00
Abstract dependency processing from Makefile generation
Allows multiple consumers
- - - - -
13dd8d66 by fendor at 2026-09-24T14:05:47+02:00
Add json output format
- - - - -
23 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/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/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/lib/B.hs
- + 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,67 @@ 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
-----------------------------------------------------------------
--
@@ -98,27 +120,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
- -- If -ddump-mod-cycles, show cycles in the module graph
- liftIO $ dumpModCycles logger module_graph
+ -- 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
+
+ -- 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 +169,201 @@ doMkDependModuleGraph dflags module_graph = do
--`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
+--------------------------------------------------------------------------------
+-- Types abstracting over the output
+--------------------------------------------------------------------------------
+
+data DepNode =
+ DepNode
+ { dn_mod :: Module
+ , dn_src :: OsPath
+ , dn_obj :: OsPath
+ , dn_hi :: OsPath
+ , dn_boot :: IsBootInterface
+ , 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_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 = ms_mod node
+ , dn_src = src_file
+ , dn_obj = msObjFileOsPath node
+ , dn_hi = msHiFileOsPath node
+ , dn_boot = isBootSummary node
+ , dn_preprocessing = preproc
+ }
+
+ preprocessor :: IO PreprocessingNode
+ preprocessor
+ | Just src <- ml_hs_file_ospath (ms_location node)
+ = runPipeline (hsc_hooks hsc_env) $ do
+ let
+ (_, suffix) = OsPath.splitExtension src
+ srcFn = unsafeDecodeUtf src
+ lit | Unlit _ <- startPhase (unsafeDecodeUtf suffix) = True
+ | otherwise = False
+ pipe_env = mkPipeEnv StopPreprocess srcFn Nothing NoOutputFile
+ unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env srcFn) else pure srcFn
+ (dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (hsc_dflags hsc_env) 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
+ }
+
+ 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,175 +437,86 @@ 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
+ | IsBoot <- dn_boot
+ = [([obj], hi) | (obj, hi) <- zip (suffixed (removeBootSuffix dn_obj)) (suffixed dn_hi)]
+ | otherwise
+ = []
+
+ -- 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
-
- -- 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)
+ | otherwise
+ -> []
- ; (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)
+ DepCpp {dep_path} -> [(obj_files, dep_path)]
- ; 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))
- }
+ write (from, to) = writeDependency root hdl from to
-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)))
+ obj_files = suffixed dn_obj
- -- Not in this package: we don't need a dependency
- | otherwise
- -> return (Right Nothing)
+ suffixed f = insertSuffixes f suffixes
- 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_boot} = 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
= do let -- We need to avoid making deps on
-- c:/foo/...
- -- on Windows as make gets confused by the :
+ -- on cygwin 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 +545,186 @@ 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 PackageDeps
+ = PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName))
+ 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
+ , modules :: (Set.Set ModuleName, Set.Set ModuleName)
+ , packages :: PackageDeps
+ , cpp :: Set.Set OsPath
+ , options :: [String]
+ , preprocessor :: Maybe FilePath
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically Deps)
+
+newtype DepJson = DepJson (Map.Map ModuleName Deps)
+
+instance ToJson DepJson where
+ json (DepJson m) =
+ JSObject [
+ (moduleNameString target, JSObject [
+ ("sources", array sources (showOsPath . normalise)),
+ ("modules", array (fst modules) moduleNameString),
+ ("modules-boot", array (snd modules) moduleNameString),
+ ("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),
+ ("options", JSArray $ map JSString options),
+ ("preprocessor", maybe JSNull JSString preprocessor)
+ ])
+ | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m
+ ]
+ where
+ package name unit_id (PackageId package_id) mods =
+ JSObject [
+ ("id", JSString (unitIdString unit_id)),
+ ("name", JSString name),
+ ("package-id", JSString (unpackFS package_id)),
+ ("modules", array mods moduleNameString)
+ ]
+
+ array values render = JSArray (fmap (JSString . render) (Set.toList values))
+
+ showOsPath = unsafeDecodeUtf
+
+initDepJson :: IO (IORef DepJson)
+initDepJson = newIORef $ DepJson Map.empty
+
+insertDepJson :: [ModuleName] -> Deps -> DepJson -> DepJson
+insertDepJson targets dep (DepJson m0) =
+ DepJson
+ $ foldl'
+ ( \acc target ->
+ Map.insertWith
+ (Semigroup.<>)
+ target
+ dep
+ acc
+ )
+ m0
+ targets
+
+updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
+updateDepJson include_pkgs DepNode {..} deps =
+ insertDepJson [moduleName dn_mod] payload
+ where
+ payload = node_data Semigroup.<> foldMap dep deps
+
+ node_data =
+ mempty {
+ sources = Set.singleton dn_src,
+ preprocessor = pn_preprocessor dn_preprocessing,
+ options = pn_options dn_preprocessing
+ }
+
+ dep = \case
+ DepHi {dep_mod, dep_local, dep_unit, dep_boot}
+ | dep_local
+ , let set = Set.singleton $ moduleName dep_mod
+ value | IsBoot <- dep_boot = (Set.empty, set)
+ | otherwise = (set, Set.empty)
+ -> mempty {modules = value}
+
+ | 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)
+ key = (lname, unitId unit, DPackageId $ unitPackageId unit)
+ -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton $ moduleName dep_mod))}
+
+ | otherwise
+ -> mempty
+
+ DepCpp {dep_path} ->
+ mempty {cpp = Set.singleton dep_path}
+
-----------------------------------------------------------------
-- 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
=====================================
@@ -760,6 +760,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 }
@@ -1245,6 +1251,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/tests/driver/T24384/A.hs
=====================================
@@ -0,0 +1,5 @@
+{-# language Strict #-}
+{-# options_ghc -fexpose-all-unfoldings #-}
+module A where
+
+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,48 @@
+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 | jq --sort-keys
=====================================
testsuite/tests/driver/T24384/T24384a.stdout
=====================================
@@ -0,0 +1,31 @@
+# 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 : /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 : 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/all.T
=====================================
@@ -0,0 +1,8 @@
+test_extras = extra_files(
+ ['A.hs', 'lib/', 'C.hs', 'C.hs-boot', 'D.hs', 'E.hs',
+ 'dep', 'dep-internal', 'dep-public',
+ 'preproc.sh'
+ ])
+
+test('T24384a', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, [])
+test('T24384b', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], 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/lib/B.hs
=====================================
@@ -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/51dc8da5c57b99d1f1badd271e2fd3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51dc8da5c57b99d1f1badd271e2fd3…
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/apk/unfold-dicts] Tweak inlining discout for unary class ops.
by Andreas Klebinger (＠AndreasK) 24 Sep '26
by Andreas Klebinger (＠AndreasK) 24 Sep '26
24 Sep '26
Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC
Commits:
aed70669 by Andreas Klebinger at 2026-09-18T07:51:26+00:00
Tweak inlining discout for unary class ops.
Correctly account for arguments applied to the result of the class op
application when computing rhs size for unary classes.
I also fixed handling of casts/ticks while in the area.
Fixes #27802
Fixes 27818
-------------------------
Metric Decrease:
CoOpt_Singletons
Metric Increase:
T12234
T21839c
T21839r
T5321FD
T5321Fun
-------------------------
- - - - -
1 changed file:
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -335,6 +335,10 @@ isValFun :: CoreExpr -> Bool
-- one top-level value lambda
isValFun (Lam b e) | isRuntimeVar b = True
| otherwise = isValFun e
+-- A tick can be code which *can* change the runtime semantics here.
+-- But we want to ignore it anyway. See Note [Ticks and Cast should not impact unfolding guidance]
+isValFun (Tick _t e) = isValFun e
+isValFun (Cast e _co) = isValFun e
isValFun _ = False
calcUnfoldingGuidance
@@ -669,6 +673,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
is_inline_scrut (Var v) =
isUnliftedType (idType v)
-- isUnliftedType is OK here: scrutinees have a fixed RuntimeRep (search for FRRCase)
+ -- Even if this makes the check technically wrong we want to
+ -- look through ticks here.
+ -- See Note [Ticks and Cast should not impact unfolding guidance]
+ is_inline_scrut (Tick _t e) = is_inline_scrut e
+ is_inline_scrut (Cast e _co) = is_inline_scrut e
is_inline_scrut scrut
| (Var f, _) <- collectArgs scrut
= case idDetails f of
@@ -709,7 +718,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
FCallId _ -> sizeN (callSize (length val_args) voids)
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op _ -> primOpSize op (length val_args)
- ClassOpId cls _ -> classOpSize opts cls top_args val_args
+ ClassOpId cls _ -> classOpSize opts cls top_args val_args voids
_ | fun `hasKey` buildIdKey -> buildSize
| fun `hasKey` augmentIdKey -> augmentSize
| otherwise -> funSize opts top_args fun (length val_args) voids
@@ -761,9 +770,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
-- and typePrimRep will crash
isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id)
- isZeroBitExpr (Var id) = isZeroBitId id
- isZeroBitExpr (Tick _ e) = isZeroBitExpr e
- isZeroBitExpr _ = False
+ -- [Ticks and Cast should not impact unfolding guidance]
+ isZeroBitExpr (Var id) = isZeroBitId id
+ isZeroBitExpr (Tick _t e) = isZeroBitExpr e
+ isZeroBitExpr (Cast e _co) = isZeroBitExpr e
+ isZeroBitExpr _ = False
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
@@ -777,21 +788,29 @@ litSize _other = 0 -- Must match size of nullary constructors
-- Key point: if x |-> 4, then x must inline unconditionally
-- (eg via case binding)
-classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize
+classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> Int -> ExprSize
-- See (IA1) in Note [Interesting arguments] in GHC.Core.Opt.Simplify.Utils
-classOpSize _opts _cls _top_args []
+classOpSize _opts _cls _top_args [] _voids
= sizeZero -- A non-applied classop
-classOpSize opts cls top_args (dict_arg:other_val_args)
- = SizeIs size (arg_discount dict_arg) 0
+classOpSize opts cls top_args (dict_arg:other_val_args) voids
+ = SizeIs size dict_arg_discount 0
where
- size | isUnaryClass cls = 0 -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon
- | otherwise = 20 + (10 * length other_val_args)
+ -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon
+ op_app_size = if isUnaryClass cls then 0 else 20
+
+ -- Size penalty for applying the extracted class method to it's
+ -- arguments.
+ method_app_size = callSize (length other_val_args) voids
+
+ size = op_app_size + method_app_size
-- If the class op is scrutinising a lambda bound dictionary then
-- give it a discount, to encourage the inlining of this function
- arg_discount (Cast arg _co) = arg_discount arg
- arg_discount (Var dict) | dict `elem` top_args = unitBag (dict, dict_discount)
- arg_discount _ = emptyBag
+ dict_arg_discount = case getIdFromTrivialExpr_maybe dict_arg of
+ Nothing -> emptyBag
+ Just var
+ | var `elem` top_args -> unitBag (var, dict_discount)
+ | otherwise -> emptyBag
-- If we have (class-op d arg1 .. argn) then it's super-good to inline
-- to expose `d`; not only can we do the dictionary selection
@@ -1051,6 +1070,23 @@ In a function application (f a b)
get a saturated application)
Code for manipulating sizes
+
+Note [Ticks and Cast should not impact unfolding guidance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to ignore ticks and casts when
+computing unfolding guidance. The reason is simple:
+
+We want inlining to be robust if a user changes a type alias
+to a newtype, if the code is otherwise the same.
+
+Similarly we want inlining to behave the same for a core expression
+(<tick> e) as it does for `e`.
+This is **independent** of the kind of tick we are dealing with.
+Even for ticks that represent code at runtime we generally want
+to inline as-if no tick is present. This way profiled code will
+be closer to non-profiled code, which leads to more accurate profiles.
+
+So we take care to look through Cast/Ticks wherever possible.
-}
-- | The size of a candidate expression for unfolding
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aed7066985d8cea9c236ac95c98e6f0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aed7066985d8cea9c236ac95c98e6f0…
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] 3 commits: Abstract dependency processing from Makefile generation
by Hannes Siebenhandl (＠fendor) 24 Sep '26
by Hannes Siebenhandl (＠fendor) 24 Sep '26
24 Sep '26
Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC
Commits:
3dece9c4 by fendor at 2026-09-24T13:22:00+02:00
Abstract dependency processing from Makefile generation
Allows multiple consumers
- - - - -
147961b3 by fendor at 2026-09-24T13:22:54+02:00
Add json output format
- - - - -
51dc8da5 by fendor at 2026-09-24T13:22:56+02:00
Add -dep-json test with multiple deps
- - - - -
20 changed files:
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Session.hs
- docs/users_guide/separate_compilation.rst
- + 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/T24384.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/lib/B.hs
- + 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
@@ -19,8 +21,9 @@ import GHC.Prelude
import GHC qualified
import GHC.Data.Bag (listToBag)
+import GHC.Data.FastString (lexicalCompareFS, unpackFS)
import GHC.Data.Graph.Directed (SCC (..))
-import GHC.Data.OsPath (unsafeDecodeUtf, unsafeEncodeUtf)
+import GHC.Data.OsPath
import GHC.Driver.DynFlags
import GHC.Driver.Env
@@ -52,6 +55,7 @@ import GHC.Unit.State (lookupUnitId)
import GHC.Utils.Error
import GHC.Utils.Exception
+import GHC.Utils.Json
import GHC.Utils.Logger
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -63,12 +67,18 @@ 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 qualified System.OsString as OsString
+import qualified Data.Monoid as Monoid
-----------------------------------------------------------------
--
@@ -110,27 +120,53 @@ 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
+
+ root_ <- liftIO getCurrentDirectory
+ root <- encodeUtf root_
+ let
+ dep_writer =
+ concat
+ [ [ SomeDependencyWriter $ initFileDepWriter logger root tmpfs dflags
+ ]
+ , [ SomeDependencyWriter $ initJsonDepWriter json_output dflags
+ | Just json_output <- [depJson dflags]
+ ]
+ ]
- files <- liftIO $ beginMkDependHS logger tmpfs dflags
- let sorted = GHC.topSortModuleGraph False module_graph Nothing
+ 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 (UniqSet.mkUniqSet excl_mods) root (mkd_tmp_hdl files)) sorted
+ liftIO $ do
- -- If -ddump-mod-cycles, show cycles in the module graph
- liftIO $ dumpModCycles logger module_graph
+ writers <- traverse
+ (\ (SomeDependencyWriter writer) -> do
+ backend <- dw_beginWriter writer
+ pure $ SomeActiveDependencyWriter (writer, backend)
+ )
+ dep_writer
+
+ do
+ -- Process them one by one, dumping results and complaining about cycles
+ mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) writers) sorted
+
+ -- If -ddump-mod-cycles, show cycles in the module graph
+ liftIO $ dumpModCycles logger module_graph
+
+ -- Tidy up
+ do
+ traverse_
+ (\ (SomeActiveDependencyWriter (writer, backend)) -> do
+ dw_endWriter writer backend
+ )
+ 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
@@ -139,67 +175,6 @@ doMkDependModuleGraph dflags module_graph = do
--`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
------------------------------------------------------------------
---
--- beginMkDependHs
--- Create a temporary file,
--- find the Makefile,
--- slurp through it, etc
---
------------------------------------------------------------------
-
-data MkDepFiles
- = MkDep { mkd_make_file :: FilePath, -- Name of the makefile
- mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
- mkd_tmp_file :: FilePath, -- Name of the temporary file
- mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
-
-beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
-beginMkDependHS logger tmpfs dflags = do
- -- open a new temp file in which to stuff the dependency info
- -- as we go along.
- tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"
- tmp_hdl <- openFile tmp_file WriteMode
-
- -- open the makefile
- let makefile = depMakefile dflags
- exists <- doesFileExist makefile
- mb_make_hdl <-
- if not exists
- then return Nothing
- else do
- makefile_hdl <- openFile makefile ReadMode
-
- -- slurp through until we get the magic start string,
- -- copying the contents into dep_makefile
- let slurp = do
- l <- hGetLine makefile_hdl
- if (l == depStartMarker)
- then return ()
- else do hPutStrLn tmp_hdl l; slurp
-
- -- slurp through until we get the magic end marker,
- -- throwing away the contents
- let chuck = do
- l <- hGetLine makefile_hdl
- if (l == depEndMarker)
- then return ()
- else chuck
-
- catchIO slurp
- (\e -> if isEOFError e then return () else ioError e)
- catchIO chuck
- (\e -> if isEOFError e then return () else ioError e)
-
- return (Just makefile_hdl)
-
-
- -- write the magic marker into the tmp file
- hPutStrLn tmp_hdl depStartMarker
-
- return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
- mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
-
--------------------------------------------------------------------------------
-- Types abstracting over the output
--------------------------------------------------------------------------------
@@ -207,9 +182,9 @@ beginMkDependHS logger tmpfs dflags = do
data DepNode =
DepNode
{ dn_mod :: Module
- , dn_src :: FilePath
- , dn_obj :: FilePath
- , dn_hi :: FilePath
+ , dn_src :: OsPath
+ , dn_obj :: OsPath
+ , dn_hi :: OsPath
, dn_boot :: IsBootInterface
, dn_preprocessing :: PreprocessingNode
}
@@ -222,15 +197,24 @@ data PreprocessingNode = PreprocessingNode
data Dep
= DepHi
{ dep_mod :: Module
- , dep_path :: FilePath
+ , dep_path :: OsPath
, dep_unit :: Maybe UnitInfo
, dep_local :: Bool
, dep_boot :: IsBootInterface
}
| DepCpp
- { dep_path :: FilePath
+ { dep_path :: OsPath
}
+data SomeDependencyWriter = forall backend . SomeDependencyWriter (DependencyWriter backend)
+
+data SomeActiveDependencyWriter = forall backend . SomeActiveDependencyWriter (DependencyWriter backend, backend)
+
+data DependencyWriter backend = DependencyWriter
+ { dw_beginWriter :: IO backend
+ , dw_writeDependency :: backend -> DepNode -> [Dep] -> IO ()
+ , dw_endWriter :: backend -> IO ()
+ }
-----------------------------------------------------------------
--
@@ -241,8 +225,7 @@ data Dep
processDeps :: DynFlags
-> HscEnv
-> UniqSet ModuleName -- ^ Excludes
- -> FilePath
- -> Handle -- Write dependencies to here
+ -> [SomeActiveDependencyWriter]
-> SCC ModuleGraphNode
-> IO ()
-- Write suitable dependencies to handle
@@ -260,23 +243,23 @@ processDeps :: DynFlags
--
-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
-processDeps _ hsc_env _ _ _ (CyclicSCC nodes)
+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))
+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 {})))
+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
+processDeps dflags hsc_env excl_mods backends (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do
pp <- preprocessor
let
dep_node = mkDepNode pp
@@ -288,33 +271,33 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN
if null missing_dep_errs
then do
- writeDependencies include_pkg_deps root hdl extra_suffixes dep_node deps
+ traverse_ (\ (SomeActiveDependencyWriter (writer, backend)) -> dw_writeDependency writer backend dep_node deps) backends
else do
let sec = initSourceErrorContext (hsc_dflags hsc_env)
throwErrors sec (mkMessages (listToBag missing_dep_errs))
where
- extra_suffixes = depSuffixes dflags
- include_pkg_deps = depIncludePkgDeps dflags
- src_file = msHsFilePath node
- mkDepNode opts =
- DepNode {
- dn_mod = ms_mod node,
- dn_src = src_file,
- dn_obj = msObjFilePath node,
- dn_hi = msHiFilePath node,
- dn_boot = isBootSummary node,
- dn_preprocessing = opts
- }
+ src_file = msHsFileOsPath node
+ mkDepNode preproc =
+ DepNode
+ { dn_mod = ms_mod node
+ , dn_src = src_file
+ , dn_obj = msObjFileOsPath node
+ , dn_hi = msHiFileOsPath node
+ , dn_boot = isBootSummary node
+ , dn_preprocessing = preproc
+ }
preprocessor :: IO PreprocessingNode
preprocessor
- | Just src <- ml_hs_file (ms_location node)
+ | Just src <- ml_hs_file_ospath (ms_location node)
= runPipeline (hsc_hooks hsc_env) $ do
- let (_, suffix) = 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
+ let
+ (_, suffix) = OsPath.splitExtension src
+ srcFn = unsafeDecodeUtf src
+ lit | Unlit _ <- startPhase (unsafeDecodeUtf suffix) = True
+ | otherwise = False
+ pipe_env = mkPipeEnv StopPreprocess srcFn Nothing NoOutputFile
+ unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env srcFn) else pure srcFn
(dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (hsc_dflags hsc_env) unlit_fn)
let pp = pgm_F dflags1
pure PreprocessingNode
@@ -341,10 +324,14 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN
-- 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 = do
- session <- Session <$> newIORef hsc_env
- parsedMod <- reflectGhc (GHC.parseModule node) session
- pure (DepCpp <$> GHC.pm_extra_src_files parsedMod)
+ 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]
@@ -356,7 +343,6 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN
, not $ mod `UniqSet.elementOfUniqSet` excl_mods
]
-
findDependency :: HscEnv
-> UnresolvedImport PkgQual -- The import to find
-> IO (Either (MsgEnvelope GhcMessage) Dep) -- Interface file
@@ -369,7 +355,7 @@ findDependency hsc_env imp = do
pure $ Right
DepHi
{ dep_mod = dep_mod
- , dep_path = ml_hi_file loc
+ , 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
@@ -385,11 +371,83 @@ findDependency hsc_env imp = do
L srcloc mod_name = ui_mod_name imp
is_boot = ui_boot imp
+-----------------------------------------------------------------
+--
+-- beginMkDependHs
+-- Create a temporary file,
+-- find the Makefile,
+-- slurp through it, etc
+--
+-----------------------------------------------------------------
+
+initFileDepWriter :: Logger -> OsPath -> TmpFs -> DynFlags -> DependencyWriter MkDepFiles
+initFileDepWriter logger root tmpfs dflags = DependencyWriter
+ { dw_beginWriter = beginMkDependHS logger tmpfs dflags
+ , dw_writeDependency = \ backend node deps -> do
+ writeDependencies (depIncludePkgDeps dflags) root (mkd_tmp_hdl backend) suffixes node deps
+ , dw_endWriter = endMkDependHS logger
+ }
+ 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
+ mkd_tmp_file :: FilePath, -- Name of the temporary file
+ mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
+
+beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
+beginMkDependHS logger tmpfs dflags = do
+ -- open a new temp file in which to stuff the dependency info
+ -- as we go along.
+ tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"
+ tmp_hdl <- openFile tmp_file WriteMode
+
+ -- open the makefile
+ let makefile = depMakefile dflags
+ exists <- Directory.doesFileExist makefile
+ mb_make_hdl <-
+ if not exists
+ then return Nothing
+ else do
+ makefile_hdl <- openFile makefile ReadMode
+
+ -- slurp through until we get the magic start string,
+ -- copying the contents into dep_makefile
+ let slurp = do
+ l <- hGetLine makefile_hdl
+ if (l == depStartMarker)
+ then return ()
+ else do hPutStrLn tmp_hdl l; slurp
+
+ -- slurp through until we get the magic end marker,
+ -- throwing away the contents
+ let chuck = do
+ l <- hGetLine makefile_hdl
+ if (l == depEndMarker)
+ then return ()
+ else chuck
+
+ catchIO slurp
+ (\e -> if isEOFError e then return () else ioError e)
+ catchIO chuck
+ (\e -> if isEOFError e then return () else ioError e)
+
+ return (Just makefile_hdl)
+
+
+ -- write the magic marker into the tmp file
+ hPutStrLn tmp_hdl depStartMarker
+
+ return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
+ mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
+
writeDependencies ::
Bool ->
- FilePath ->
+ OsPath ->
Handle ->
- [FilePath] ->
+ [OsString] ->
+ -- ^ Suffixes
DepNode ->
[Dep] ->
IO ()
@@ -406,7 +464,7 @@ writeDependencies include_pkgs root hdl suffixes node deps =
-- files if the module has a corresponding .hs-boot file (#14482)
boot_dep
| IsBoot <- dn_boot
- = [([obj], hi) | (obj, hi) <- zip (suffixed (viaOsPath removeBootSuffix dn_obj)) (suffixed dn_hi)]
+ = [([obj], hi) | (obj, hi) <- zip (suffixed (removeBootSuffix dn_obj)) (suffixed dn_hi)]
| otherwise
= []
@@ -414,10 +472,9 @@ writeDependencies include_pkgs root hdl suffixes node deps =
-- e.g. A.o : B.hi
-- A.x_o : B.x_hi
import_dep = \case
- DepHi {dep_path, dep_boot, dep_unit}
+ DepHi {dep_path, dep_unit}
| isNothing dep_unit || include_pkgs
- , let path = if dep_boot == IsBoot then viaOsPath addBootSuffix dep_path else dep_path
- -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed path)]
+ -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed dep_path)]
| otherwise
-> []
@@ -432,10 +489,8 @@ writeDependencies include_pkgs root hdl suffixes node deps =
DepNode {dn_src, dn_obj, dn_hi, dn_boot} = node
- viaOsPath f a = unsafeDecodeUtf (f (unsafeEncodeUtf a))
-
-----------------------------
-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
@@ -443,33 +498,30 @@ writeDependency root hdl targets dep
-- c:/foo/...
-- on cygwin 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 ()
@@ -498,6 +550,185 @@ endMkDependHS logger
showPass logger "Installing new makefile"
SysTools.copyFile tmp_file makefile
+-----------------------------------------------------------------
+--
+-- JSON MkDepends output
+--
+-----------------------------------------------------------------
+
+initJsonDepWriter :: FilePath -> DynFlags -> DependencyWriter (JsonOutput DepJson)
+initJsonDepWriter output dflags = DependencyWriter
+ { dw_beginWriter = do
+ mkJsonOutput output initDepJson
+ , dw_writeDependency = \ backend node deps -> do
+ updateJson backend (updateDepJson (depIncludePkgDeps dflags) node deps)
+ , dw_endWriter =
+ writeJsonOutput
+ }
+
+--------------------------------------------------------------------------------
+-- 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 PackageDeps
+ = PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName))
+ 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
+ , modules :: (Set.Set ModuleName, Set.Set ModuleName)
+ , packages :: PackageDeps
+ , cpp :: Set.Set OsPath
+ , options :: [String]
+ , preprocessor :: Maybe FilePath
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically Deps)
+
+newtype DepJson = DepJson (Map.Map ModuleName Deps)
+
+instance ToJson DepJson where
+ json (DepJson m) =
+ JSObject [
+ (moduleNameString target, JSObject [
+ ("sources", array sources (showOsPath . normalise)),
+ ("modules", array (fst modules) moduleNameString),
+ ("modules-boot", array (snd modules) moduleNameString),
+ ("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),
+ ("options", JSArray $ map JSString options),
+ ("preprocessor", maybe JSNull JSString preprocessor)
+ ])
+ | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m
+ ]
+ where
+ package name unit_id (PackageId package_id) mods =
+ JSObject [
+ ("id", JSString (unitIdString unit_id)),
+ ("name", JSString name),
+ ("package-id", JSString (unpackFS package_id)),
+ ("modules", array mods moduleNameString)
+ ]
+
+ array values render = JSArray (fmap (JSString . render) (Set.toList values))
+
+ showOsPath = unsafeDecodeUtf
+
+initDepJson :: IO (IORef DepJson)
+initDepJson = newIORef $ DepJson Map.empty
+
+insertDepJson :: [ModuleName] -> Deps -> DepJson -> DepJson
+insertDepJson targets dep (DepJson m0) =
+ DepJson
+ $ foldl'
+ ( \acc target ->
+ Map.insertWith
+ (Semigroup.<>)
+ target
+ dep
+ acc
+ )
+ m0
+ targets
+
+updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
+updateDepJson include_pkgs DepNode {..} deps =
+ insertDepJson [moduleName dn_mod] payload
+ where
+ payload = node_data Semigroup.<> foldMap dep deps
+
+ node_data =
+ mempty {
+ sources = Set.singleton dn_src,
+ preprocessor = pn_preprocessor dn_preprocessing,
+ options = pn_options dn_preprocessing
+ }
+
+ dep = \case
+ DepHi {dep_mod, dep_local, dep_unit, dep_boot}
+ | dep_local
+ , let set = Set.singleton $ moduleName dep_mod
+ value | IsBoot <- dep_boot = (Set.empty, set)
+ | otherwise = (set, Set.empty)
+ -> mempty {modules = value}
+
+ | 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)
+ key = (lname, unitId unit, DPackageId $ unitPackageId unit)
+ -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton $ moduleName dep_mod))}
+
+ | otherwise
+ -> mempty
+
+ DepCpp {dep_path} ->
+ mempty {cpp = Set.singleton dep_path}
+
-----------------------------------------------------------------
-- Module cycles
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -760,6 +760,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 }
@@ -1245,6 +1251,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/tests/driver/T24384/A.hs
=====================================
@@ -0,0 +1,5 @@
+{-# language Strict #-}
+{-# options_ghc -fexpose-all-unfoldings #-}
+module A where
+
+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,38 @@
+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:
+ $(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
+
+ '$(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 | jq --sort-keys
=====================================
testsuite/tests/driver/T24384/T24384.stdout
=====================================
@@ -0,0 +1,157 @@
+{
+ "A": {
+ "cpp": [],
+ "modules": [],
+ "modules-boot": [
+ "C"
+ ],
+ "options": [
+ "-XStrict",
+ "-fexpose-all-unfoldings"
+ ],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "A.hs"
+ ]
+ },
+ "B": {
+ "cpp": [],
+ "modules": [
+ "A"
+ ],
+ "modules-boot": [],
+ "options": [
+ "-F",
+ "-pgmF",
+ "./preproc.sh"
+ ],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ }
+ ],
+ "preprocessor": "./preproc.sh",
+ "sources": [
+ "lib/B.hs"
+ ]
+ },
+ "C": {
+ "cpp": [],
+ "modules": [
+ "A",
+ "E"
+ ],
+ "modules-boot": [],
+ "options": [],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ },
+ {
+ "id": "containers-0.8-inplace",
+ "modules": [
+ "Data.Set"
+ ],
+ "name": "containers",
+ "package-id": "containers-0.8"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "C.hs",
+ "C.hs-boot"
+ ]
+ },
+ "D": {
+ "cpp": [],
+ "modules": [
+ "B",
+ "C"
+ ],
+ "modules-boot": [],
+ "options": [],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "D.hs"
+ ]
+ },
+ "E": {
+ "cpp": [],
+ "modules": [],
+ "modules-boot": [],
+ "options": [],
+ "packages": [
+ {
+ "id": "base-4.23.0.0-inplace",
+ "modules": [
+ "GHC.Essentials",
+ "Prelude"
+ ],
+ "name": "base",
+ "package-id": "base-4.23.0.0"
+ },
+ {
+ "id": "dep-1-XXX",
+ "modules": [
+ "Dep"
+ ],
+ "name": "dep",
+ "package-id": "dep-1"
+ },
+ {
+ "id": "dep-public-1-XXX",
+ "modules": [
+ "DepPublic"
+ ],
+ "name": "dep-public",
+ "package-id": "dep-public-1"
+ },
+ {
+ "id": "template-haskell-2.25.0.0-inplace",
+ "modules": [
+ "Language.Haskell.TH.Syntax"
+ ],
+ "name": "template-haskell",
+ "package-id": "template-haskell-2.25.0.0"
+ }
+ ],
+ "preprocessor": null,
+ "sources": [
+ "E.hs"
+ ]
+ }
+}
=====================================
testsuite/tests/driver/T24384/all.T
=====================================
@@ -0,0 +1,7 @@
+test('T24384',
+ [ extra_files(['A.hs', 'lib/', 'C.hs', 'C.hs-boot', 'D.hs', 'E.hs',
+ 'dep', 'dep-internal', 'dep-public',
+ 'preproc.sh'
+ ])
+ ],
+ 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/lib/B.hs
=====================================
@@ -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/92d1b66eeb430a86a5453dd8e4c47a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92d1b66eeb430a86a5453dd8e4c47a…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/worker-gbc
by Torsten Schmits (＠torsten.schmits) 24 Sep '26
by Torsten Schmits (＠torsten.schmits) 24 Sep '26
24 Sep '26
Torsten Schmits pushed new branch wip/torsten.schmits/worker-gbc at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/worker-gbc
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/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 24 Sep '26
by Andreas Klebinger (＠AndreasK) 24 Sep '26
24 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
ed81c0f0 by Andreas Klebinger at 2026-09-24T09:48:53+00:00
.hi files: Various encoding improvements
Binders: Encode non-linear binders more efficiently.
There is no need to serialize the Many type. We just use one bit to
encode that there is an implicit Many as multiplicity when writing to
disk.
Names: Use the low rather than high bit to encode the "compactness".
Since we encode name references as LEB128 using the high bit forces
5-byte references. By using the low bit we can actually compress the
small references when when storing name references using putName.
This allows use to LEB128 encode the combination of tag + value efficiently.
instance Binary Integer:
We used to use a tag byte to store if it fits in a Int64, and if not the
sign and then encode the actual value as LEB128.
Instead we now just encode as SLEB128. The only real downside is that we
have to discover during LEB decoding if we need to swap from Int to
Integer. This saves one byte for small values.
instance Binary iteral:
Don't encode it pointwise. Instead encode the Literal con tag + LitNumberType in a single tag
byte. Followed by the actual value if we deal with number literals.
This saves a byte per literal for small numbers.
`IfaceApp`: There is no real benefit to avoid collapsing chains of
applications. So we add a explicit constructor for n-ary applications.
We could do this just in the Binary instance. But in this case I felt
there is no real downside to express this in the type itself. So I
added:
IfaceApps IfaceExpr [IfaceExpr]
Of course we use a small trick. We use parts of the IFaceExpr tag space
to encode arity of the application. So we don't have to store the length
of the list in the common case.
Saves ~1 byte per argument. Exactly one for small applications. If we
serialize the list length slightly less.
`IfaceAlt`: Improve the encoding
We avoid storing the length for the always-empty lists on _DEFAULT and
literal alternatives by dispatching on the alt type.
`IfaceCase`: Add a special case for single default alts, encoded via
one of the tag bits from `IfaceExpr`.
Generally .hi files get a few % smaller. With a relative big variance with some files
getting more then 20% smaller.
-------------------------
Metric Decrease:
if_ifacetype
-------------------------
- - - - -
14 changed files:
- + changelog.d/T27808-iface-encoding-improvements
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Utils/Binary.hs
- + testsuite/tests/utils/should_run/Binary_Literal.hs
- + testsuite/tests/utils/should_run/Binary_Literal.stdout
- testsuite/tests/utils/should_run/all.T
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
Changes:
=====================================
changelog.d/T27808-iface-encoding-improvements
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+synopsis: Improved ``.hi`` file encoding resulting in less space used on disk.
+issues: #27808
+mrs: !16683
+description: {
+ This was mostly done by moving from simple pointwise encoding to adding
+ special cases for common cases.
+}
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -651,16 +651,19 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
+-- `mkIfaceApp` is just a smart constructor for the IfaceApp[s] constructors.
+-- See Note [Iface applications] in GHC.Iface.Syntax
+mkIfaceApps f as = mkIfaceApp f (map toIfaceExpr as)
---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| isBootUnfolding (idUnfolding v)
= -- See Note [Inlining and hs-boot files]
- IfaceApp (IfaceApp (IfaceExt noinline_id)
- (IfaceType (toIfaceType ty)))
- (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
+ IfaceApps (IfaceExt noinline_id)
+ [IfaceType (toIfaceType ty), IfaceExt name]
+ -- don't use mkIfaceApps, or infinite loop since it ends up calling
+ -- toIfaceVar indirectly again.
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
-- Foreign calls have special syntax
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -741,25 +741,38 @@ In more detail:
Tuples aren't included in the wired-in names map: see (ST1) below
* Serialisation is done by `putName`:
- - When we serialise a compact Name,
- we serialise it as a single 32-bit word:
- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
- where xxxx is the tag, and yyyy is the payload.
- The function `wiredInNamesOkay` checks that the wired-in names all have
- uniques that fit into the `yyy` field.
+ - When we serialise a compact Name, we serialise its Unique, split by
+ `unpkUniqueGrimily` into the tag character and the payload:
+
+ yyyyyyyy yyyyyyyy yyyyyyyx xxxxxxx1
+ \________ payload _______/\_ tag _/^ marker bit
+
+ Why are we storing the marker/tag in the low rather than high bits? Because
+ we LEB128 encode the whole word when writing to disk so we want to keep as
+ many of the high bits zero as possible to allow for shorter encodings. See
+ also wrinkle ST3.
+
+ Tags are 8 bits by construction, and there is a check that the actual unique
+ part fits in 22 bits which `wiredInNamesOkay` (in GHC.Builtin) checks for all
+ known-key names.
- When we serialise a non-compact name:
- We look it up in the (stateful, growing) symbol table
- - If it not there we add it to the symbol table
- - We serialise the occurrenc to a single 32-bit word:
- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
- where `xxxxx` is an index into the symbol table.
+ - If it is not there we add it to the symbol table
+ - We serialise the occurrence as
-* Deserialision is done by `getName`. We read a 32-bit word
- - If the MSB is `10` it must be a compact name, so we use
+ 0xxxxxxx xxxxxxxx xxxxxxxx xxxxxxx0
+
+ In other words we simply shift the index by a bit.
+ The high bit is currently unused. But `putSymtabNameRef`
+ asserts that `ix` fits in 30 bits.
+
+* Deserialisation is done by `getSymtabName`, which dispatches on the low bit
+ of the word it reads:
+ - If it is 1 it must be a compact name, so we reassemble the Unique and use
`lookupCompactName` to get from the Unique to the Name.
- - If the MSB is `00` it must be a non-compact Name,
- so we look it up in the symbol table.
+ - If it is 0 it must be a non-compact Name, so we look it up in the
+ symbol table.
Wrinkles:
@@ -785,6 +798,20 @@ Wrinkles:
`isCompactName` that tests for `knownUniqueTupleName` and then the
TyConRepNames would be serialised as non-compact names, and everything would
work. Fewer tests, but Typeable-heavy code might have bigger interface files.
+
+(ST3) Both kinds of Name are serialised as a single `Word32`, which is serialized to
+ disk in it's ULEB128 encoded variable-length form (see `putULEB128`).
+ This has consequences as it means we want to keep the high bits zero where possible
+ to allow for a shorter ULEB128 encoding.
+
+ This is why we put both the tag and the marker bit at the LSB end of the word. They
+ are always present. But by putting them at the low end we ensure LEB128 encoding
+ still works as expected, producing smaller encodings for compact names with small
+ uniques.
+
+ The downside is that we steal one bit from non-compact names for which the marker
+ bit and tag would have been zero either way. But in practice this matters far less
+ than ensuring built in (compact) names encode well.
-}
isCompactName :: Name -> Bool
@@ -803,6 +830,31 @@ lookupCompactName u
where
(tag, ix) = unpkUniqueGrimily u
+-- | Write a reference to a symbol table index.
+-- See Note [Symbol table representation of names]
+putSymtabNameRef :: WriteBinHandle -> Int -> IO ()
+{-# INLINE putSymtabNameRef #-}
+putSymtabNameRef bh ix
+ = assertPpr (ix >= 0 && ix < (1 `shiftL` 30))
+ (text "putSymtabNameRef: symbol table index out of range:" <+> int ix) $
+ -- Bit 0 == False marks a symbol table reference
+ put_ bh ((fromIntegral ix `shiftL` 1) :: Word32)
+
+-- | Write a reference to a compact (known-key) 'Name'.
+-- See Note [Symbol table representation of names]
+putCompactNameRef :: WriteBinHandle -> Unique -> IO ()
+{-# INLINE putCompactNameRef #-}
+putCompactNameRef bh uniq
+ = -- INVARIANTS:
+ -- * 8 bits tag (true by construction)
+ -- * the payload fits in 22 bits (checked for all known keys elsewhere)
+ -- Bit 0 == True marks a compact (known-key) name
+ put_ bh ( (fromIntegral payload `shiftL` 9)
+ .|. (fromIntegral (ord tag) `shiftL` 1)
+ .|. 1 :: Word32)
+ where
+ (tag, payload) = unpkUniqueGrimily uniq
+
-- See Note [Symbol table representation of names]
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName BinSymbolTable{
@@ -810,16 +862,12 @@ putName BinSymbolTable{
bin_symtab_next = symtab_next }
bh name
| isCompactName name
- , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- assert (u < 2^(22 :: Int))
- put_ bh (0x80000000
- .|. (fromIntegral (ord c) `shiftL` 22)
- .|. (fromIntegral u :: Word32))
+ = putCompactNameRef bh (nameUnique name)
| otherwise
= do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putSymtabNameRef bh off
Nothing -> do
off <- freshIndex
let mod = nameModule name
@@ -829,12 +877,11 @@ putName BinSymbolTable{
let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' )
- put_ bh (fromIntegral off :: Word32)
+ putSymtabNameRef bh off
where
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
- -- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
return off
@@ -843,12 +890,10 @@ getSymtabName :: SymbolTable Name
-> ReadBinHandle -> IO Name
getSymtabName symtab bh = do
i :: Word32 <- get bh
- case i .&. 0xC0000000 of
- 0x00000000 -> return $! symtab ! fromIntegral i
- 0x80000000 -> return $! lookupCompactName u
- where
- tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
- ix = fromIntegral i .&. 0x003FFFFF
- u = mkUniqueGrimilyWithTag tag ix
-
- _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+ if i .&. 1 == 0
+ then -- Symbol table reference, written by putSymtabNameRef
+ return $! symtab ! fromIntegral (i `shiftR` 1)
+ else -- Compact name, written by putCompactNameRef
+ let tag = chr (fromIntegral ((i `shiftR` 1) .&. 0xFF))
+ payload = fromIntegral (i `shiftR` 9) :: Word64
+ in return $! lookupCompactName (mkUniqueGrimilyWithTag tag payload)
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -828,6 +828,8 @@ rnIfaceExpr (IfaceLam lam_bndr expr)
= IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
rnIfaceExpr (IfaceApp fun arg)
= IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceApps fun args)
+ = IfaceApps <$> rnIfaceExpr fun <*> rnIfaceExprs args
rnIfaceExpr (IfaceCase scrut case_bndr alts)
= IfaceCase <$> rnIfaceExpr scrut
<*> pure case_bndr
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -10,7 +10,8 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
- IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
+ IfaceExpr(..), mkIfaceApp,
+ IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -96,8 +97,8 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
- zipWithEqual )
+import GHC.Utils.Misc( dropList, filterByList, notNull,
+ unzipWith, zipWithEqual )
import GHC.Data.FastString
import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
@@ -700,6 +701,11 @@ data IfaceExpr
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceLamBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
+ -- ^ Application to exactly one argument.
+ -- See Note [Iface applications]
+ | IfaceApps IfaceExpr [IfaceExpr]
+ -- ^ Application to two or more arguments.
+ -- See Note [Iface applications]
| IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr
@@ -710,6 +716,18 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
+-- | Apply an expression to a (possibly empty) list of arguments, maintaining
+-- the invariants of 'IfaceApp' and 'IfaceApps'.
+-- See Note [Iface applications].
+mkIfaceApp :: IfaceExpr -> [IfaceExpr] -> IfaceExpr
+mkIfaceApp fun args = go fun args
+ where
+ go (IfaceApp f a) as = go f (a : as)
+ go (IfaceApps f fs) as = go f (fs ++ as)
+
+ go f [] = f
+ go f [a] = IfaceApp f a
+ go f as = IfaceApps f as
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
@@ -745,6 +763,30 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
{-
+Note [Iface applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A Core application chain (f a1 a2 ... an) could be represented by a chain of
+n nested IfaceApp nodes like Core does. However this is generally a worse
+representation for *serialization* which is the main purpose of the Iface type.
+
+So we keep the single argument constructor as it's fairly common, and add one
+to represent multiple arguments:
+
+ * IfaceApp f a -- exactly one argument
+ * IfaceApps f [a1,..] -- two or more arguments
+
+with two invariants:
+
+ (1) The argument list of an IfaceApps has at least two elements.
+ (A one-argument application is an IfaceApp, and a zero-argument
+ "application" is just the head itself.)
+
+ (2) The head of an IfaceApp or IfaceApps is never itself an IfaceApp or
+ IfaceApps: application chains are fully flattened.
+
+The smart constructor 'mkIfaceApp' establishes both invariants; producers
+should use it rather than building IfaceApps directly.
+
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Iface syntax an IfaceCase does not record the types of the alternatives,
@@ -1797,7 +1839,8 @@ pprIfaceExpr _ (IfaceLitRubbish tc r)
<> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" })
<> parens (ppr r)
-pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
+pprIfaceExpr add_par app@(IfaceApps _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr add_par i@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
@@ -1869,9 +1912,13 @@ pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+-- NB: IfaceApps must print exactly like the equivalent IfaceApp chain, so
+-- that --show-iface output does not depend on which one the producer emitted.
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
nest 2 (pprParendIfaceExpr arg) : args
-pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApps fun as) args = pprIfaceApp fun $
+ map (nest 2 . pprParendIfaceExpr) as ++ args
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceConAlt where
@@ -2170,6 +2217,7 @@ freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceApps f as) = freeNamesIfExpr f &&& fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
@@ -2830,17 +2878,46 @@ infixl 9 .<<|.
x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
{-# INLINE (.<<|.) #-}
+-- Encoding shortcuts:
+-- Since only IfaceDataAlt can have binders
+-- we can skip the binder list for DEFAULT and Literal alternatives.
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
put_ bh a
- put_ bh b
+ case a of
+ IfaceDataAlt {} -> put_ bh b
+ _ -> assertPpr (null b) (ppr a $$ ppr b) $ return ()
put_ bh c
get bh = do
a <- get bh
- b <- get bh
+ b <- case a of
+ IfaceDataAlt {} -> get bh
+ _ -> return []
c <- get bh
return (IfaceAlt a b c)
+{- Note [IfaceExpr encoding shortcuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use a full byte to encode the constructor tag for `IfaceExpr`.
+This leaves room to encode additional information. Concretely we
+use:
+
+0 .. 14: "Simple" constructor tags.
+15 .. 22: "IfaceApps", encoding the constructor *and* arity.
+ 23: "IfaceCase" for a case with a single default alternative.
+
+Note [Binary encoding of IfaceApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For IfaceApps we use the following scheme:
+
+ * arity 2..8: one byte encoding the arity as (15 + (n-2))
+ Which is followed by the head expression and then exactly `arity` arguments.
+
+ * arity > 8: tag 22, and we serialize the argument count as a ULEB128, followed by the
+ head expression and arguments.
+
+This saves us one byte per application with `2 <= arity <= 8`.
+-}
instance Binary IfaceExpr where
put_ bh (IfaceLcl aa) = do
putByte bh 0
@@ -2864,6 +2941,12 @@ instance Binary IfaceExpr where
putByte bh 5
put_ bh ag
put_ bh ah
+ -- See Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak]) = do
+ putByte bh 23
+ put_ bh ai
+ put_ bh aj
+ put_ bh ak
put_ bh (IfaceCase ai aj ak) = do
putByte bh 6
put_ bh ai
@@ -2899,6 +2982,17 @@ instance Binary IfaceExpr where
putByte bh 14
put_ bh r
put_ bh torc
+ -- See Note [Iface applications] and Note [Binary encoding of IfaceApps]
+ -- and Note [IfaceExpr encoding shortcuts]
+ put_ bh (IfaceApps fun args) = do
+ let !n = length args
+ massertPpr (n >= 2) (text "put_ IfaceApps" <+> ppr n)
+ if n <= maxIfaceAppsTagArity
+ then putByte bh (fromIntegral (ifaceAppsTag0 + n - 2))
+ else do putByte bh (fromIntegral ifaceAppsBigTag)
+ put_ bh n
+ put_ bh fun
+ mapM_ (put_ bh) args
get bh = do
h <- getByte bh
case h of
@@ -2944,7 +3038,41 @@ instance Binary IfaceExpr where
14 -> do r <- get bh
torc <- get bh
return (IfaceLitRubbish torc r)
+ -- Tags 15..21 encode an IfaceApps of arity 2..8 in the tag itself;
+ -- tag 22 is followed by an explicit (LEB128) argument count.
+ -- See Note [Binary encoding of IfaceApps]
+ 15 -> getApps 2
+ 16 -> getApps 3
+ 17 -> getApps 4
+ 18 -> getApps 5
+ 19 -> getApps 6
+ 20 -> getApps 7
+ 21 -> getApps 8
+ 22 -> do n <- get bh
+ getApps n
+ -- case scrut of bndr { DEFAULT -> rhs}
+ 23 -> do ai <- get bh
+ aj <- get bh
+ ak <- get bh
+ return (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak])
_ -> panic ("get IfaceExpr " ++ show h)
+ where
+ getApps :: Int -> IO IfaceExpr
+ getApps n = do fun <- get bh
+ args <- replicateM n (get bh)
+ return (IfaceApps fun args)
+-- | Tag used for an 'IfaceApps' with exactly two arguments and start
+-- of the ifaceApps tag range.
+ifaceAppsTag0 :: Int
+ifaceAppsTag0 = 15
+
+-- | Highest arity encoded directly in tag byte.
+maxIfaceAppsTagArity :: Int
+maxIfaceAppsTagArity = 8
+
+-- | Tag for an 'IfaceApps' whose arity is serialized as ULEB128.
+ifaceAppsBigTag :: Int
+ifaceAppsBigTag = 22
instance Binary IfaceTickish where
put_ bh (IfaceHpcTick m ix) = do
@@ -3211,6 +3339,7 @@ instance NFData IfaceExpr where
IfaceTuple sort exprs -> rnf sort `seq` rnf exprs
IfaceLam bndr expr -> rnf bndr `seq` rnf expr
IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
+ IfaceApps e es -> rnf e `seq` rnf es
IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
IfaceECase e ty -> rnf e `seq` rnf ty
IfaceLet bind e -> rnf bind `seq` rnf e
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1073,7 +1073,18 @@ pprIfaceTyConBinders suppress_sig = sep . map go
where
ppr_bndr = pprIfaceTvBndr bndr suppress_sig
+-- | IfaceBndr shortcuts:
+--
+-- In the vast majority of cases binder multiplicity is `Many` so storing it is
+-- a pure waste of space. Instead of storing (Many, Name, Ty) we simply store
+-- (Name,Ty) in the common case where multiplicity == Many.
instance Binary IfaceBndr where
+ put_ bh (IfaceIdBndr (mult, name, ty))
+ -- The implicit Many shortcut.
+ | mult == many_ty = do
+ putByte bh 2
+ put_ bh name
+ put_ bh ty
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
put_ bh aa
@@ -1085,8 +1096,11 @@ instance Binary IfaceBndr where
case h of
0 -> do aa <- get bh
return (IfaceIdBndr aa)
- _ -> do ab <- get bh
+ 1 -> do ab <- get bh
return (IfaceTvBndr ab)
+ _ -> do name <- get bh
+ ty <- get bh
+ return (IfaceIdBndr (many_ty, name, ty))
instance Binary IfaceOneShot where
put_ bh IfaceNoOneShot =
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1446,6 +1446,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
+ ifTopFreeName (IfaceApps f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
@@ -1682,6 +1683,9 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+tcIfaceExpr (IfaceApps fun args)
+ = mkApps <$> tcIfaceExpr fun <*> mapM tcIfaceExpr args
+
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
=====================================
compiler/GHC/Types/Literal.hs
=====================================
@@ -167,7 +167,7 @@ data LitNumType
| LitNumWord16 -- ^ @Word16#@ - exactly 16 bits
| LitNumWord32 -- ^ @Word32#@ - exactly 32 bits
| LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
- deriving (Data,Enum,Eq,Ord)
+ deriving (Data,Enum,Eq,Ord,Bounded)
-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
@@ -259,6 +259,38 @@ for more details.
-}
+{-
+Note [Binary Literal encoding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather than write `LitNumType` into it's own tag byte we encode it in the
+surplus space of the `Literal` tag space.
+
+This means for `Literal` tag 0 .. 5 are the non-num literals.
+Literals 6 .. (maxBound LitNumType) encode the LitNumType.
+
+We could use the `LitNumType` information to slightly improve the encoding of
+the actual values too. But we just write/read them at Integer for simplicity for
+now.
+-}
+
+-- | The 'Binary' tag byte of @'LitNumber' nt _@.
+--
+-- These continue the tags of the non-numeric 'Literal' constructors. The
+-- mapping is total and part of the interface file format.
+-- See Note [Binary Literal encoding].
+litNumTypeTag :: LitNumType -> Word8
+litNumTypeTag nt =
+ -- 6 .. 16
+ 6 + (fromIntegral $ fromEnum nt)
+
+-- | The inverse of 'litNumTypeTag'. 'Nothing' for a tag which isn't the tag
+-- of a numeric literal. See Note [Binary Literal encoding].
+litNumTypeOfTag :: Word8 -> Maybe LitNumType
+litNumTypeOfTag tag
+ | tag >= 6 && tag <= 16
+ = Just (toEnum $ (fromIntegral tag) - 6)
+ | otherwise = Nothing
+
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
@@ -269,9 +301,10 @@ instance Binary Literal where
= do putByte bh 5
put_ bh aj
put_ bh fod
+ -- The LitNumType is part of the tag byte.
+ -- See Note [Binary Literal encoding]
put_ bh (LitNumber nt i)
- = do putByte bh 6
- put_ bh nt
+ = do putByte bh (litNumTypeTag nt)
put_ bh i
put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit)
-- We use IfaceLitRubbish; see Note [Rubbish literals], item (6)
@@ -296,11 +329,11 @@ instance Binary Literal where
aj <- get bh
fod <- get bh
return (LitLabel aj fod)
- 6 -> do
- nt <- get bh
- i <- get bh
- return (LitNumber nt i)
- _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
+ _ | Just nt <- litNumTypeOfTag h
+ -> do i <- get bh
+ return (LitNumber nt i)
+ | otherwise
+ -> pprPanic "Binary:Literal" (int (fromIntegral h))
instance NFData Literal where
rnf (LitChar c) = rnf c
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -393,7 +393,7 @@ unpkUnique u = case unpkUniqueGrimily u of
isValidKnownKeyUnique :: Unique -> Bool
isValidKnownKeyUnique u =
case unpkUniqueGrimily u of
- (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
+ (c, x) -> ord c < 0xff && x < (1 `shiftL` 22)
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -148,7 +148,7 @@ import GHCi.FFI
import GHCi.Message
import Control.DeepSeq
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Control.Monad ( when, unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.Base (unsafeFreezeIOArray)
@@ -173,7 +173,6 @@ import Data.Proxy
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time hiding ( Nominal )
-import Data.List (unfoldr)
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
import Type.Reflection ( Typeable, SomeTypeRep(..) )
@@ -181,6 +180,7 @@ import Type.Reflection.Unsafe
import qualified Type.Reflection as Refl
import GHC.Real ( Ratio(..) )
import GHC.Float
+
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import GHC.ByteOrder
@@ -805,6 +805,7 @@ getULEB128 bh =
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Integer -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
@@ -1123,86 +1124,92 @@ instance Binary IsBootInterface where
False -> NotBoot
{-
-Finally - a reasonable portable Integer instance.
-
-We used to encode values in the Int32 range as such,
-falling back to a string of all things. In either case
-we stored a tag byte to discriminate between the two cases.
-
-This made some sense as it's highly portable but also not very
-efficient.
-
-However GHC stores a surprisingly large number of large Integer
-values. In the examples looked at between 25% and 50% of Integers
-serialized were outside of the Int32 range.
+Note [Integer serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We simply encode Integer as SLEB128 unconditionally.
-Consider a value like `2724268014499746065`, some sort of hash
-actually generated by GHC.
-In the old scheme this was encoded as a list of 19 chars. This
-gave a size of 77 Bytes, one for the length of the list and 76
-since we encode chars as Word32 as well.
+This is a tradeoff:
+It allows shorter encodings for the common case of small values. And we don't need
+to prefix the string with a byte carrying any information about size or sign.
-We can easily do better. The new plan is:
+However it means large Integer values will pay some overhead. Their encoding can
+go from 9 (1 prefix, 8 value) to 10 bytes. Such values will also end up encoding
+into a `Integer` accumulator rather than a simple Word64#.
-* Start with a tag byte
- * 0 => Int64 (LEB128 encoded)
- * 1 => Negative large integer
- * 2 => Positive large integer
-* Followed by the value:
- * Int64 is encoded as usual
- * Large integers are encoded as a list of bytes (Word8).
- We use Data.Bits which defines a bit order independent of the representation.
- Values are stored LSB first.
+In practice interface files have enough small values to make this tradeoff worthwhile.
+We could also restore this benefit by using one or two *bits* rather than a full
+byte for the prefix. I imagine this would be worthwhile in runtime, but I've not
+gone as for for the sake of avoiding complexity.
-This means our example value `2724268014499746065` is now only 10 bytes large.
-* One byte tag
-* One byte for the length of the [Word8] list.
-* 8 bytes for the actual date.
-The new scheme also does not depend in any way on
-architecture specific details.
-
-We still use this scheme even with LEB128 available,
-as it has less overhead for truly large numbers. (> maxBound :: Int64)
-
-The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
-}
instance Binary Integer where
+ -- See Note [Integer serialisation]
put_ bh i
- | i >= lo64 && i <= hi64 = do
- putWord8 bh 0
- put_ bh (fromIntegral i :: Int64)
- | otherwise = do
- if i < 0
- then putWord8 bh 1
- else putWord8 bh 2
- put_ bh (unroll $ abs i)
- where
- lo64 = fromIntegral (minBound :: Int64)
- hi64 = fromIntegral (maxBound :: Int64)
- get bh = do
- int_kind <- getWord8 bh
- case int_kind of
- 0 -> fromIntegral <$!> (get bh :: IO Int64)
- -- Large integer
- 1 -> negate <$!> getInt
- 2 -> getInt
- _ -> panic "Binary Integer - Invalid byte"
- where
- getInt :: IO Integer
- getInt = roll <$!> (get bh :: IO [Word8])
-
-unroll :: Integer -> [Word8]
-unroll = unfoldr step
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `shiftR` 8)
+ | i >= toInteger (minBound :: Int)
+ , i <= toInteger (maxBound :: Int)
+ = putSLEB128 bh (fromInteger i :: Int)
+ | otherwise
+ = putSLEB128 bh i
+ get bh = getSLEB128Integer bh
-roll :: [Word8] -> Integer
-roll = foldl' unstep 0 . reverse
+-- | Read an SLEB128 encoded 'Integer'.
+--
+-- Unlike 'getSLEB128' this doesn't require a 'FiniteBits' instance, which
+-- 'Integer' lacks. See Note [Integer serialisation].
+getSLEB128Integer :: ReadBinHandle -> IO Integer
+getSLEB128Integer bh = go_word 0 0
where
- unstep a b = a `shiftL` 8 .|. fromIntegral b
+ -- Accumulate in a Word64 for as long as possible
+ go_word :: Int -> Word64 -> IO Integer
+ go_word !shift !acc = do
+ byte <- getByte bh
+ let !byteVal = clearBit byte 7
+ let more = testBit byte 7
+ let !shift' = shift + 7 -- bits read *after* this step
+ -- Check if the payload still fits in the accumulator,
+ -- if not swap to a Integer accumulator.
+ if shift' <= 64
+ then do
+ let !acc' = acc .|. (fromIntegral byteVal `unsafeShiftL` shift)
+ if more
+ then go_word shift' acc'
+ else return $! signExtendWord shift' acc' (testBit byte 6)
+ else do
+ -- They don't, so from here on out we use Integer arithmetic.
+ let !acc' = toInteger acc .|. (toInteger byteVal `shiftL` shift)
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ go_big :: Int -> Integer -> IO Integer
+ go_big !shift !acc = do
+ byte <- getByte bh
+ let !acc' = acc .|. (toInteger (clearBit byte 7) `shiftL` shift)
+ let !more = testBit byte 7
+ let !shift' = shift + 7
+ if more
+ then go_big shift' acc'
+ else return $! signExtendInteger shift' acc' (testBit byte 6)
+
+ -- Sign extend a value of which we read `shift` bits into a Word64.
+ -- `shift` is always <= 64 here, so the result always fits into an Int64.
+ signExtendWord :: Int -> Word64 -> Bool -> Integer
+ signExtendWord !shift !acc signed
+ | not signed
+ = toInteger acc
+ | shift < 64
+ -- set high bits not encoded in the payload
+ = toInteger (fromIntegral (acc .|. (complement 0 `unsafeShiftL` shift)) :: Int64)
+ | otherwise
+ = toInteger (fromIntegral acc :: Int64)
+
+ -- Sign extend into an Integer.
+ signExtendInteger :: Int -> Integer -> Bool -> Integer
+ signExtendInteger !shift !acc signed
+ | signed = acc - (1 `shiftL` shift)
+ | otherwise = acc
{-
=====================================
testsuite/tests/utils/should_run/Binary_Literal.hs
=====================================
@@ -0,0 +1,284 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+-- LLM generated test. So if it's weird it's for no good reason.
+--
+-- Property tests for the 'Binary' instance of 'Literal' in GHC.Types.Literal.
+--
+-- We check that
+-- * arbitrary literals round trip through 'put_' and 'get',
+-- * a whole batch of literals written into one buffer reads back in order,
+-- that is the reader consumes exactly the bytes the writer produced,
+-- * and, since numeric literals carry an 'Integer', that the SLEB128 based
+-- 'Binary Integer' instance agrees with a reference implementation.
+module Main (main) where
+
+import GHC.Data.FastString
+import GHC.Platform ( genericPlatform )
+import GHC.Types.Basic ( FunctionOrData(..) )
+import GHC.Types.Literal
+import GHC.Types.Literal.Floating
+import GHC.Utils.Binary
+
+import Control.Monad ( replicateM )
+import Data.Bits
+import qualified Data.ByteString as BS
+import Data.Ratio ( (%) )
+import Data.Word
+import GHC.Float ( castFloatToWord32, castWord32ToFloat
+ , castDoubleToWord64, castWord64ToDouble )
+import Numeric ( showHex )
+import System.IO.Unsafe ( unsafePerformIO )
+
+import MiniQuickCheck
+
+--------------------------------------------------------------------------------
+-- Encoding and decoding
+
+-- | 'LitLabel' contains a 'FastString', which the 'Binary' instance writes
+-- through a table in the handle's user data. Interface files fill this in with
+-- a deduplication table. We only need something that round trips, so we write
+-- the bytes of the string inline.
+withFastStringWriter :: WriteBinHandle -> WriteBinHandle
+withFastStringWriter = addWriterToUserData (BinaryWriter (\bh fs -> put_ bh (bytesFS fs)))
+
+withFastStringReader :: ReadBinHandle -> ReadBinHandle
+withFastStringReader = addReaderToUserData (BinaryReader (\bh -> mkFastStringByteString <$> get bh))
+
+-- | Serialise the values and also return the position after the last of them.
+encodeAll :: Binary a => [a] -> (BS.ByteString, Bin ())
+encodeAll xs = unsafePerformIO $ do
+ bh <- withFastStringWriter <$> openBinMem 1024
+ mapM_ (put_ bh) xs
+ end <- tellBinWriter bh
+ bs <- withBinBuffer bh (return . BS.copy)
+ return (bs, end)
+
+encode :: Binary a => a -> BS.ByteString
+encode x = fst (encodeAll [x])
+
+-- | Read back @n@ values and check that doing so consumed exactly the bytes
+-- the writer produced, no more and no less.
+decodeAll :: Binary a => Int -> (BS.ByteString, Bin ()) -> [a]
+decodeAll n (bs, end) = unsafePerformIO $ do
+ bh <- withFastStringReader <$> unsafeUnpackBinBuffer bs
+ xs <- replicateM n (get bh)
+ end' <- tellBinReader bh
+ if end' == end
+ then return xs
+ else fail $ "reader stopped at " ++ show end' ++ ", writer at " ++ show end
+
+roundTrip :: Binary a => [a] -> [a]
+roundTrip xs = decodeAll (length xs) (encodeAll xs)
+
+roundTrip1 :: Binary a => a -> a
+roundTrip1 x = case roundTrip [x] of
+ [x'] -> x'
+ _ -> error "roundTrip1"
+
+--------------------------------------------------------------------------------
+-- Literals with structural equality and a Show instance
+
+-- | 'Literal' has neither a 'Show' instance nor an 'Eq' instance which compares
+-- all fields: 'LitLabel' ignores the 'FunctionOrData' and 'LitFloating'
+-- identifies the different representations of the same value. For a
+-- serialisation test we want the stricter notion.
+newtype Lit = Lit Literal
+
+instance Show Lit where
+ show (Lit l) = showLit l
+
+instance Eq Lit where
+ Lit a == Lit b = eqLit a b
+
+eqLit :: Literal -> Literal -> Bool
+eqLit (LitLabel fs1 fod1) (LitLabel fs2 fod2)
+ = fs1 == fs2 && fod1 == fod2
+eqLit (LitFloating ty1 v1) (LitFloating ty2 v2)
+ -- 'Eq LitFloating' compares NaNs bitwise but identifies different
+ -- representations of the same value; the derived 'Show' distinguishes the
+ -- representations but not NaN payloads. Together they compare structurally.
+ = ty1 == ty2 && v1 == v2 && show v1 == show v2
+eqLit a b = a == b
+
+showLit :: Literal -> String
+showLit lit = case lit of
+ LitChar c -> "LitChar " ++ show c
+ LitNumber nt i -> "LitNumber " ++ showLitNumType nt ++ " " ++ show i
+ LitString bs -> "LitString " ++ show bs
+ LitNullAddr -> "LitNullAddr"
+ LitRubbish {} -> "LitRubbish"
+ LitFloating ty v -> "LitFloating " ++ show ty ++ " (" ++ show v ++ ") " ++ bits ty v
+ LitLabel fs fod -> "LitLabel " ++ show (bytesFS fs) ++ " " ++ showFod fod
+ where
+ -- The bit pattern is needed to tell apart NaNs.
+ bits LitFloat v = "0x" ++ showHex (castFloatToWord32 (litFloatingToHostFloat v)) ""
+ bits LitDouble v = "0x" ++ showHex (castDoubleToWord64 (litFloatingToHostDouble v)) ""
+
+ showFod IsFunction = "IsFunction"
+ showFod IsData = "IsData"
+
+showLitNumType :: LitNumType -> String
+showLitNumType nt = case nt of
+ LitNumBigNat -> "LitNumBigNat"
+ LitNumInt -> "LitNumInt"
+ LitNumInt8 -> "LitNumInt8"
+ LitNumInt16 -> "LitNumInt16"
+ LitNumInt32 -> "LitNumInt32"
+ LitNumInt64 -> "LitNumInt64"
+ LitNumWord -> "LitNumWord"
+ LitNumWord8 -> "LitNumWord8"
+ LitNumWord16 -> "LitNumWord16"
+ LitNumWord32 -> "LitNumWord32"
+ LitNumWord64 -> "LitNumWord64"
+
+--------------------------------------------------------------------------------
+-- Generators
+
+-- | A number in @[0, n)@. Uses the high bits of the LCG state, which are the
+-- more random ones.
+choose :: Int -> Gen Int
+choose n = (`mod` n) . fromIntegral . (`shiftR` 32) <$> arbitraryWord64
+
+oneOf :: [Gen a] -> Gen a
+oneOf gens = do
+ i <- choose (length gens)
+ gens !! i
+
+listOf :: Int -> Gen a -> Gen [a]
+listOf maxLen gen = do
+ n <- choose (maxLen + 1)
+ replicateM n gen
+
+-- | 'MiniQuickCheck's 'Integer' instance generates values of up to 192 bits,
+-- which rarely hit the boundaries of the SLEB128 encoding. So we mix in small
+-- values and values around powers of two.
+genInteger :: Gen Integer
+genInteger = oneOf
+ [ arbitrary
+ , fromIntegral . subtract 300 <$> choose 601
+ , do k <- choose 200
+ d <- subtract 2 <$> choose 5
+ neg <- arbitrary
+ let v = 2 ^ k + toInteger d
+ return (if neg then negate v else v)
+ ]
+
+genLitNumType :: Gen LitNumType
+genLitNumType = oneOf (map pure [LitNumBigNat ..])
+
+-- | Numeric literals are always in range for their type, see
+-- Note [Word/Int underflow/overflow] in GHC.Types.Literal. The encoding is
+-- free to rely on that, so we generate only such literals.
+genLitNumber :: Gen Literal
+genLitNumber = do
+ nt <- genLitNumType
+ i <- genInteger
+ -- 'mkLitNumberWrap' wraps into the range of the fixed width types but
+ -- refuses negative 'BigNat's.
+ let i' | LitNumBigNat <- nt = abs i
+ | otherwise = i
+ return (mkLitNumberWrap genericPlatform nt i')
+
+-- | Random bit patterns, so that we also get infinities, negative zero,
+-- subnormals and NaNs with various payloads.
+genFloat :: Gen Float
+genFloat = castWord32ToFloat <$> arbitrary
+
+genDouble :: Gen Double
+genDouble = castWord64ToDouble <$> arbitrary
+
+genRational :: Gen Rational
+genRational = do
+ n <- genInteger
+ NonZero d <- arbitrary @(NonZero Integer)
+ return (n % d)
+
+genLitFloating :: Gen LitFloating
+genLitFloating = oneOf
+ [ floatToLitFloating <$> genFloat
+ , doubleToLitFloating <$> genDouble
+ , rationalToLitFloating <$> genRational
+ ]
+
+genLitFloatingType :: Gen LitFloatingType
+genLitFloatingType = oneOf [ pure LitFloat, pure LitDouble ]
+
+-- | Not valid UTF8
+genByteString :: Gen BS.ByteString
+genByteString = BS.pack <$> listOf 64 arbitrary
+
+genLabel :: Gen FastString
+genLabel = mkFastString <$> listOf 64 arbitrary
+
+genFunctionOrData :: Gen FunctionOrData
+genFunctionOrData = oneOf [ pure IsFunction, pure IsData ]
+
+-- | Any literal except 'LitRubbish', which has no 'Binary' encoding, see
+-- Note [Rubbish literals] in GHC.Types.Literal.
+genLiteral :: Gen Literal
+genLiteral = oneOf
+ [ LitChar <$> arbitrary
+ , genLitNumber
+ , LitString <$> genByteString
+ , pure LitNullAddr
+ , LitFloating <$> genLitFloatingType <*> genLitFloating
+ , LitLabel <$> genLabel <*> genFunctionOrData
+ ]
+
+instance Arbitrary Lit where
+ arbitrary = Lit <$> genLiteral
+
+newtype Lits = Lits [Lit]
+ deriving (Eq, Show)
+
+instance Arbitrary Lits where
+ arbitrary = Lits <$> listOf 32 arbitrary
+
+newtype I = I Integer
+ deriving (Eq, Show)
+
+instance Arbitrary I where
+ arbitrary = I <$> genInteger
+
+--------------------------------------------------------------------------------
+-- Properties
+
+-- | Reference implementation of the SLEB128 encoding.
+slebRef :: Integer -> [Word8]
+slebRef = go
+ where
+ go val =
+ let byte = fromIntegral (val .&. 0x7f) :: Word8
+ val' = val `shiftR` 7
+ signBit = testBit byte 6
+ done = (val' == 0 && not signBit) || (val' == -1 && signBit)
+ in if done
+ then [byte]
+ else setBit byte 7 : go val'
+
+prop_literalRoundTrip :: Lit -> PropertyCheck
+prop_literalRoundTrip (Lit l) = Lit (roundTrip1 l) === Lit l
+
+prop_literalBatchRoundTrip :: Lits -> PropertyCheck
+prop_literalBatchRoundTrip (Lits ls) = Lits (map Lit (roundTrip [ l | Lit l <- ls ])) === Lits ls
+
+prop_integerRoundTrip :: I -> PropertyCheck
+prop_integerRoundTrip (I i) = roundTrip1 i === i
+
+prop_integerEncoding :: I -> PropertyCheck
+prop_integerEncoding (I i) = BS.unpack (encode i) === slebRef i
+
+tests :: Test
+tests = Group "Binary"
+ [ Group "Literal"
+ [ Property "round trip" prop_literalRoundTrip
+ , Property "batch round trip" prop_literalBatchRoundTrip
+ ]
+ , Group "Integer"
+ [ Property "round trip" prop_integerRoundTrip
+ , Property "SLEB128 encoding" prop_integerEncoding
+ ]
+ ]
+
+main :: IO ()
+main = runTestsMain (Iterations 1000) tests
=====================================
testsuite/tests/utils/should_run/Binary_Literal.stdout
=====================================
@@ -0,0 +1,11 @@
+Group Binary
+ Group Literal
+ Running round trip
+ Passed 1000 iterations
+ Running batch round trip
+ Passed 1000 iterations
+ Group Integer
+ Running round trip
+ Passed 1000 iterations
+ Running SLEB128 encoding
+ Passed 1000 iterations
=====================================
testsuite/tests/utils/should_run/all.T
=====================================
@@ -1 +1,6 @@
test('T15953', [ignore_stdout, js_skip], makefile_test, [])
+
+# Property tests for the 'Binary Literal' instance, which also exercises
+# GHCs 'Binary Integer' instance.
+test('Binary_Literal', [mini_quickcheck], multimod_compile_and_run,
+ ['Binary_Literal', '-package ghc'])
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -60,6 +60,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Data.Text as T
import Haddock.Options (Visibility (..))
+import qualified Data.Bits as Bits
data InterfaceFile = InterfaceFile
{ ifLinkEnv :: LinkEnv
@@ -143,7 +144,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(10,2,0)
-binaryInterfaceVersion = 47
+binaryInterfaceVersion = 48
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -274,7 +275,7 @@ putName
do
(symtab_map, symtab_tbl) <- readIORef symtab_map_ref
case lookupNameEnv symtab_map name of
- Just off -> put_ bh (fromIntegral off :: Word32)
+ Just off -> putNameIndex (fromIntegral off :: Word32)
Nothing -> do
off <- freshIndex
let mod' = nameModule name
@@ -283,8 +284,10 @@ putName
let !symtab_map' = extendNameEnv symtab_map name off
let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
- put_ bh (fromIntegral off :: Word32)
+ putNameIndex (fromIntegral off)
where
+ putNameIndex :: Word32 -> IO ()
+ putNameIndex off = put_ bh (off `Bits.shiftL` 1)
freshIndex :: IO Int
freshIndex = do
off <- readFastMutInt symtab_next
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed81c0f0bb5df3fd8a439e1a7ffb3df…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed81c0f0bb5df3fd8a439e1a7ffb3df…
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/improve-closure-property-check] 2 commits: Re-implement the home unit closure check
by Wolfgang Jeltsch (＠jeltsch) 24 Sep '26
by Wolfgang Jeltsch (＠jeltsch) 24 Sep '26
24 Sep '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC
Commits:
64799b05 by Wolfgang Jeltsch at 2026-09-24T12:28:41+03:00
Re-implement the home unit closure check
Compared to the previous implementation, the new one has the following
advantages:
* It is correct.
- It distinguishes between units that have the same unit ID but
different ABI hashes.
- When `-hide-all-packages` is not used, it considers as home unit
dependencies also units that are made implicitly available
because they are in the package database.
* It seems to be faster in usual settings.
- In particular, it does not have a preparation phase in which it
merges the dependency information from all home units, so that
its running time does not grow linearly with the size of the
package database in normal Cabal scenarios.
* It is (hopefully) clearer.
* It is better documented.
- - - - -
dabbc669 by Wolfgang Jeltsch at 2026-09-24T12:29:26+03:00
Remove erroneous GHC flag in `hadrian-multi`
The flag was `-Werror=-Wno-error=incomplete-record-selectors`. Its
purpose was to permit incomplete record selectors, but because of the
illegal combination of `-Werror=` and `-Wno-error` it was ignored,
without any negative consequences.
- - - - -
7 changed files:
- .gitlab-ci.yml
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile
- testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr
- testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -497,12 +497,7 @@ hadrian-multi:
# workaround for docker permissions
- sudo chown ghc:ghc -R .
variables:
- GHC_FLAGS: "-Werror=-Wno-error=incomplete-record-selectors -Wwarn=deprecations -Wwarn=unused-imports"
- # -Wno-error=incomplete-record-selectors is present because -Wall now
- # includes -Wincomplete-record-selectors, and hadrian-multi has many, many
- # warnings about incomplete record selectors. A better fix would be to
- # remove the use of incomplete record selectors, since each of them represents
- # a potential crash.
+ GHC_FLAGS: "-Wwarn=deprecations -Wwarn=unused-imports"
CONFIGURE_ARGS: --enable-bootstrap-with-devel-snapshot
tags:
- x86_64-linux
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -6,6 +6,8 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-invalid-haddock #-}
+
-- | See Note [The ModuleGraph]
module GHC.Driver.Downsweep
( downsweep
@@ -54,8 +56,6 @@ import GHC.Runtime.Context
import Language.Haskell.Syntax.ImpExp
import GHC.Types.UnresolvedImport
-import GHC.Data.Graph.Directed
-import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import qualified GHC.Data.Maybe as M
import GHC.Data.OsPath ( OsPath, unsafeEncodeUtf )
@@ -71,12 +71,15 @@ import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Utils.TmpFs
import GHC.Utils.Constants
+import GHC.Utils.Monad (concatMapM)
+import GHC.Utils.Monad.State.Strict
import GHC.Types.Error
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
+import GHC.Types.Unique.Set
import GHC.Types.Unique.Map
import GHC.Types.PkgQual
import GHC.Types.Basic
@@ -91,9 +94,12 @@ import GHC.Unit.Module.Graph
import GHC.Unit.Module.Deps
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Module.Stage
+import GHC.Unit.External.Index (UnitAbiHash)
import Data.Either ( partitionEithers, lefts )
+import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Set (Set)
import qualified Data.Set as Set
import Control.Concurrent.MVar
@@ -101,7 +107,7 @@ import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.Maybe
-import Data.List (partition)
+import Data.List (sort, partition)
import Data.Time
import Data.List (unfoldr)
import Data.Bifunctor (first, bimap)
@@ -864,7 +870,7 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target
mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
| TargetModule modl <- targetId
= do
- let root_imp = (generatedImport FromTarget (L rootLoc modl))
+ let root_imp = (generatedImport FromTarget (L noSrcSpan modl))
{ ui_pkg_qual = ThisPkg (homeUnitId home_unit) }
maybe_summary <- summariseModule hsc_env home_unit summ_cache imports_cache root_imp
maybe_buf excl_mods
@@ -875,7 +881,6 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target
where
Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target
home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline
@@ -933,52 +938,171 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
-- * Check/validate properties and error out
--------------------------------------------------------------------------------
--- | This function checks then important property that if both p and q are home units
--- then any dependency of p, which transitively depends on q is also a home unit.
+-- | Checks whether the given 'UnitEnv' has the closure property.
--
--- See Note [Multiple Home Units], section 'Closure Property'.
-checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
-checkHomeUnitsClosed ue
- | Set.null bad_unit_ids = []
- | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
+-- See the section “Closure Property” in @Note [Multiple Home Units]@ for the
+-- definition of the closure property and
+-- @Note [Home unit closure property check]@ below for a discussion of the
+-- algorithm used for this check, its justification, and a potential
+-- alternative.
+checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
+checkHomeUnitsClosed unit_env
+ | null offenders = []
+ | otherwise = [
+ singleMessage $
+ mkPlainErrorMsgEnvelope noSrcSpan $
+ DriverHomePackagesNotClosed (sort offenders)
+ ]
where
- home_id_set = HUG.allUnits $ ue_home_unit_graph ue
- bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
- downwards_closure :: Graph (Node UnitId UnitId)
- downwards_closure = graphFromEdgedVerticesUniq graphNodes
+ -- | The 'UnitId' and 'HomeUnitEnv' of each home unit.
+ home_unit_data :: [(UnitId, HomeUnitEnv)]
+ home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env)
+
+ -- | The 'UnitId's of all home units.
+ home_units :: UniqSet UnitId
+ home_units = mkUniqSet (map fst home_unit_data)
+
+ -- | All offending dependencies. A dependency of a unit /u/ on a unit /v/ is
+ -- offending exactly if /u/ is an external unit reachable from a home unit
+ -- and /v/ is a home unit. Each such dependency is represented in this list
+ -- by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/.
+ offenders :: [(UnitId, UnitId)]
+ offenders
+ = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data))
+ emptyUniqMap
+ where
- inverse_closure = graphReachability $ transposeG downwards_closure
+ -- | Collects offending dependencies.
+ collect :: [UnitState]
+ -- ^ The 'UnitState's of the home units from which to traverse
+ -- the dependency graph.
+ -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)]
+ -- ^ A stateful computation that collects offending dependencies
+ -- that have not yet been found. It uses its state, which is an
+ -- efficent representation of a set of 'GlobalUnitKey's, to
+ -- keep track of which units have already been considered as
+ -- sources of offending dependencies.
+ collect = concatMapM $ \ unit_state ->
+ collect_for_home_unit
+ (unitInfoMap unit_state)
+ (map (toUnitId . fst) $ explicitUnits $ unit_state)
+ where
- upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
+ -- | Collects offending dependencies that are reachable from a particular
+ -- home unit.
+ collect_for_home_unit
+ :: UnitInfoMap
+ -- ^ The 'UnitInfoMap' of the home unit.
+ -> [UnitId]
+ -- ^ The 'UnitId's of the units from which to traverse the dependency
+ -- graph.
+ -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)]
+ -- ^ A stateful computation that collects offending dependencies that
+ -- have not yet been found. It uses its state, which is an efficent
+ -- representation of a set of 'GlobalUnitKey's, to keep track of
+ -- which units have already been considered as sources of offending
+ -- dependencies.
+ collect_for_home_unit _ []
+ = return []
+ collect_for_home_unit unit_info_map (current_unit : remaining_units) = do
+ let
+
+ -- | The 'UnitInfo' of the current unit.
+ unit_info :: UnitInfo
+ unit_info
+ = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $
+ lookupUniqMap unit_info_map current_unit
+ where
+
+ -- | The message that says that a unit was not found.
+ unit_not_found_msg :: String
+ unit_not_found_msg = "Unit not found during closure property check"
+
+ -- | The ABI hash of the current unit.
+ unit_abi_hash :: UnitAbiHash
+ unit_abi_hash = unitAbiHash unit_info
+
+ has_been_processed <- gets $ maybe False (Set.member unit_abi_hash) .
+ (`lookupUniqMap` current_unit)
+ if has_been_processed
+ then collect_for_home_unit unit_info_map remaining_units
+ else do
+ modify $ \ processed -> addToUniqMap_C Set.union
+ processed
+ current_unit
+ (Set.singleton unit_abi_hash)
+ let
+
+ -- | The 'UnitId's of the units that the current unit depends on.
+ needed_units :: [UnitId]
+ needed_units = unitDepends unit_info
+
+ -- | The offending dependencies of the current unit.
+ current_offenders :: [(UnitId, UnitId)]
+ current_offenders
+ | current_unit `elementOfUniqSet` home_units
+ = []
+ | otherwise
+ = map ((,) current_unit) $
+ nonDetEltsUniqSet $
+ mkUniqSet needed_units `intersectUniqSets` home_units
+
+ remaining_offenders <- collect_for_home_unit unit_info_map $
+ needed_units ++ remaining_units
+ return $ current_offenders ++ remaining_offenders
- all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
- all_unit_direct_deps
- = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
- where
- go rest this this_uis =
- plusUniqMap_C Set.union
- (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
- rest
- where
- external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
- this_units = homeUnitEnv_units this_uis
- this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
-
- graphNodes :: [Node UnitId UnitId]
- graphNodes = go Set.empty home_id_set
- where
- go done todo
- = case Set.minView todo of
- Nothing -> []
- Just (uid, todo')
- | Set.member uid done -> go done todo'
- | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
- Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
- Just depends ->
- let todo'' = (depends Set.\\ done) `Set.union` todo'
- in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
+{-
+
+Note [Home unit closure property check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Per the definition in Note [Multiple Home Units], a unit environment has the
+closure property exactly if there are no paths /h/₁ →* /e/ →* /h/₂ in the
+dependency graph, where /h/₁ and /h/₂ are home units and /e/ is an external
+unit. However, the algorithm used by 'checkHomeUnitsClosed' searches for
+so-called offending dependencies, which are dependencies /e/ → /h/₂ that are
+part of a path /h/₁ →* /e/ → /h/₂ in the dependency graph. To see that this is a
+viable approach, consider the following:
+
+ * A path /h/₁ →* /e/ → /h/₂ is also a path /h/₁ →* /e/ →* /h/₂.
+
+ * For each path /h/₁ →* /e/ →* /h/₂, there exists a path /h/₁ →* /e/′ → /h/₂′,
+ where /e/′ is an external unit and /h/₂′ is a home unit. Such a path can be
+ constructed by taking as /h/₂′ the first home unit on the path /e/ →* /h/₂
+ and as /e/′ the, necessarily external, unit preceding it.
+
+Concretely, the algorithm picks one home unit after the other, determines what
+units it directly depends on, and, starting from them, follows unit dependencies
+to search for offending dependencies. It does not follow dependencies that have
+been followed before, possibly when processing another home unit. To achieve
+this, the algorithm tracks, across home units, from which units it has already
+followed dependencies. For this tracking, it identifies each unit by a 'UnitId'
+and an ABI hash. Using only a 'UnitId' would not work, because 'UnitId's are not
+always globally unique. Also using only an ABI hash is not an option, because an
+ABI hash is not necessarily an ABI hash: it can also be the string @"inline"@.
+
+The correctness of this algorithm rests on the, likely correct, assumption that,
+among the units mentioned in the 'UnitState' of a particular home unit, any unit
+can be uniquely identified by its 'UnitId' and thus 'UnitId' clashes can only
+occur across the 'UnitState's of different home units.
+
+An alternative approach to finding offending dependencies would be to follow
+dependencies starting from all units that /any/ home unit directly depends on
+instead of considering the different home units separately. A corresponding
+algorithm could in principle find the dependencies of a particular unit
+independently of any home unit by fetching the 'UnitInfo' of that unit from the
+'GlobalUnitInfoMap'. However, for such a lookup the algorithm would need not
+only the 'UnitId' but also the ABI hash of the unit in question. Therefore,
+whenever following a dependency of a unit /u/ on a unit /v/, it would have to
+determine the ABI hash of /v/, so that it could later look up /v/’s
+dependencies. The ABI hashes of all units that /u/ depends on should be
+available in the 'unitAbiDepends' field of /u/’s 'UnitInfo'. However, at the
+time of writing, 'unitAbiDepends' never contained anything other than the empty
+list during GHC test runs, which indicated that this alternative solution was
+impossible to realize.
+
+-}
--------------------------------------------------------------------------------
-- * Enable Code Gen for Template Haskell
@@ -1763,7 +1887,7 @@ data NodeRes v
--
-- See also Note [Downsweep Control Flow and Caching]
dfsBuild :: (Ord k, Monad m)
- => Maybe (Map.Map k (NodeRes v))
+ => Maybe (Map k (NodeRes v))
-- ^ Base map, existing results. We won't re-expand any of the nodes
-- already present in this map.
-> [n]
@@ -1773,7 +1897,7 @@ dfsBuild :: (Ord k, Monad m)
-> (n -> m (NodeRes (v,[n])))
-- ^ Expand this node into its payload result and into the list of
-- children nodes to visit next.
- -> m (Map.Map k (NodeRes v))
+ -> m (Map k (NodeRes v))
-- ^ The result accumulates the payload of expanding the root nodes
-- and all nodes transitively reachable from those roots.
dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -235,10 +235,17 @@ instance Diagnostic DriverMessage where
"but no output will be generated.") $$
(text "There is no module named" <+>
quotes (ppr mod_name) <> text "."))
- DriverHomePackagesNotClosed needed_unit_ids
- -> mkSimpleDecorated $ vcat ([text "Home units are not closed."
- , text "It is necessary to also load the following units:" ]
- ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)
+ DriverHomePackagesNotClosed offending_dependencies
+ -> mkSimpleDecorated $
+ hang (text "Some units are not loaded but depend on loaded units.")
+ 4
+ (vcat (map pprDependency offending_dependencies))
+ where
+
+ pprDependency :: (UnitId, UnitId) -> SDoc
+ pprDependency (external_unit, home_unit)
+ = ppr external_unit <+> arrow <+> ppr home_unit
+
DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason
DriverInconsistentDynFlags msg
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -369,7 +369,7 @@ data DriverMessage where
DriverRedirectedNoMain :: !ModuleName -> DriverMessage
- DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage
+ DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage
DriverInterfaceError :: !IfaceMessage -> DriverMessage
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile
=====================================
@@ -10,14 +10,21 @@ CONFIGURE=configure \
--ghc-options='$(TEST_HC_OPTS)' \
--package-db=../tmp.d
TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp
+ONLY_BASE=-hide-all-packages -package base
mhu-closure: clean pkg-database
- $(TEST_BUILD) -unit @unitP
- $(TEST_BUILD) -unit @unitP -unit @unitQ
+ ! $(TEST_BUILD) -unit @unitP
+ ! $(TEST_BUILD) -unit @unitP -unit @unitQ
! $(TEST_BUILD) -unit @unitP -unit @unitR
! $(TEST_BUILD) -unit @unitP -unit @unitR1
$(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR
- $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1
+ ! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1
+ $(TEST_BUILD) $(ONLY_BASE) -unit @unitP
+ $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ
+ ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR
+ ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1
+ $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR
+ $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1
.PHONY: pkg-database
pkg-database:
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr
=====================================
@@ -1,10 +1,28 @@
-<command line>: error: [GHC-03271]
- Home units are not closed.
- It is necessary to also load the following units:
- - q-0.1.0.0
-
-<command line>: error: [GHC-03271]
- Home units are not closed.
- It is necessary to also load the following units:
- - q-0.1.0.0
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ q-0.1.0.0 -> p-0.1.0.0
+
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ r-0.1.0.0 -> q-0.1.0.0
+
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ q-0.1.0.0 -> p-0.1.0.0
+
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ q-0.1.0.0 -> p-0.1.0.0
+
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ r-0.1.0.0 -> q-0.1.0.0
+
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ q-0.1.0.0 -> p-0.1.0.0
+
+<no location info>: error: [GHC-03271]
+ Some units are not loaded but depend on loaded units.
+ q-0.1.0.0 -> p-0.1.0.0
=====================================
testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout
=====================================
@@ -1,3 +1,6 @@
+[1 of 3] Compiling P[p-0.1.0.0]
+[2 of 3] Compiling Q[q-0.1.0.0]
+[3 of 3] Compiling R[r-0.1.0.0]
[1 of 1] Compiling P
[1 of 2] Compiling P[p-0.1.0.0]
[2 of 2] Compiling Q[q-0.1.0.0]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3a50a05a34de16cea00905643b751…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3a50a05a34de16cea00905643b751…
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