Simon Peyton Jones pushed new branch wip/T26725 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26725
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3d6aba77 by konsumlamm at 2026-01-06T09:33:16-05:00
Fix changelog formatting
- - - - -
1 changed file:
- libraries/base/changelog.md
Changes:
=====================================
libraries/base/changelog.md
=====================================
@@ -747,7 +747,7 @@
* `Generic1`, as well as the associated datatypes and typeclasses in
`GHC.Generics`, are now poly-kinded (#10604)
- * `New modules `Data.Bifoldable` and `Data.Bitraversable` (previously defined
+ * New modules `Data.Bifoldable` and `Data.Bitraversable` (previously defined
in the `bifunctors` package) (#10448)
* `Data.Either` now provides `fromLeft` and `fromRight` (#12402)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d6aba778f7628deef0141d9e8effc5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d6aba778f7628deef0141d9e8effc5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 5 commits: Improved fundeps for closed type families
by Marge Bot (＠marge-bot) 06 Jan '26
by Marge Bot (＠marge-bot) 06 Jan '26
06 Jan '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0b7df6db by Simon Peyton Jones at 2026-01-06T09:32:23-05:00
Improved fundeps for closed type families
The big payload of this commit is to execute the plan suggested
in #23162, by improving the way that we generate functional
dependencies for closed type families.
It is all described in Note [Exploiting closed type families]
Most of the changes are in GHC.Tc.Solver.FunDeps
Other small changes
* GHC.Tc.Solver.bumpReductionDepth. This function brings together the code that
* Bumps the depth
* Checks for overflow
Previously the two were separated, sometimes quite widely.
* GHC.Core.Unify.niFixSubst: minor improvement, removing an unnecessary
itraetion in the base case.
* GHC.Core.Unify: no need to pass an InScopeSet to
tcUnifyTysForInjectivity. It can calculate one for itself; and it is
never inspected anyway so it's free to do so.
* GHC.Tc.Errors.Ppr: slight impovement to the error message for
reduction-stack overflow, when a constraint (rather than a type) is
involved.
* GHC.Tc.Solver.Monad.wrapUnifier: small change to the API
- - - - -
fde8bd88 by Simon Peyton Jones at 2026-01-06T09:32:23-05:00
Add missing (KK4) to kick-out criteria
There was a missing case in kick-out that meant we could fail
to solve an eminently-solvable constraint.
See the new notes about (KK4)
- - - - -
00082844 by Simon Peyton Jones at 2026-01-06T09:32:23-05:00
Some small refactorings of error reporting in the typechecker
This is just a tidy-up commit.
* Add ei_insoluble to ErrorItem, to cache insolubility.
Small tidy-up.
* Remove `is_ip` and `mkIPErr` from GHC.Tc.Errors; instead enhance mkDictErr
to handle implicit parameters. Small refactor.
- - - - -
fe4cb252 by Simon Peyton Jones at 2026-01-06T09:32:24-05:00
Improve recording of insolubility for fundeps
This commit addresses #22652, by recording when the fundeps for
a constraint are definitely insoluble. That in turn improves the
perspicacity of the pattern-match overlap checker.
See Note [Insoluble fundeps]
- - - - -
df0ffaa5 by Simon Peyton Jones at 2026-01-06T09:32:24-05:00
Fix a buglet in niFixSubst
The MR of which this is part failed an assertion check extendTvSubst
because we extended the TvSubst with a CoVar. Boo.
This tiny patch fixes it, and adds the regression test from #13882
that showed it up.
- - - - -
69 changed files:
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/CtLoc.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/TyThing.hs
- docs/users_guide/9.16.1-notes.rst
- linters/lint-codes/LintCodes/Static.hs
- testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs
- testsuite/tests/indexed-types/should_fail/T12522a.hs
- testsuite/tests/indexed-types/should_fail/T26176.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
- testsuite/tests/parser/should_fail/T20654a.stderr
- testsuite/tests/pmcheck/should_compile/T15753c.hs
- + testsuite/tests/pmcheck/should_compile/T15753c.stderr
- testsuite/tests/pmcheck/should_compile/T15753d.hs
- + testsuite/tests/pmcheck/should_compile/T15753d.stderr
- + testsuite/tests/pmcheck/should_compile/T22652.hs
- + testsuite/tests/pmcheck/should_compile/T22652a.hs
- testsuite/tests/pmcheck/should_compile/all.T
- + testsuite/tests/polykinds/T13882.hs
- testsuite/tests/polykinds/all.T
- testsuite/tests/quantified-constraints/T15316A.stderr
- testsuite/tests/quantified-constraints/T17267.stderr
- testsuite/tests/quantified-constraints/T17267a.stderr
- testsuite/tests/quantified-constraints/T17267b.stderr
- testsuite/tests/quantified-constraints/T17267c.stderr
- testsuite/tests/quantified-constraints/T17267e.stderr
- testsuite/tests/quantified-constraints/T17458.stderr
- testsuite/tests/typecheck/should_compile/T16188.hs
- testsuite/tests/typecheck/should_fail/ContextStack1.stderr
- testsuite/tests/typecheck/should_fail/FD3.stderr
- testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr
- testsuite/tests/typecheck/should_fail/FunDepOrigin1b.stderr
- testsuite/tests/typecheck/should_fail/T13506.stderr
- testsuite/tests/typecheck/should_fail/T15767.stderr
- testsuite/tests/typecheck/should_fail/T19415.stderr
- testsuite/tests/typecheck/should_fail/T19415b.stderr
- testsuite/tests/typecheck/should_fail/T22924b.stderr
- + testsuite/tests/typecheck/should_fail/T23162b.hs
- + testsuite/tests/typecheck/should_fail/T23162b.stderr
- + testsuite/tests/typecheck/should_fail/T23162c.hs
- + testsuite/tests/typecheck/should_fail/T23162d.hs
- testsuite/tests/typecheck/should_fail/T25325.stderr
- testsuite/tests/typecheck/should_fail/T5236.stderr
- testsuite/tests/typecheck/should_fail/T5246.stderr
- testsuite/tests/typecheck/should_fail/T5978.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail143.stderr
- utils/haddock/haddock-api/src/Haddock/Convert.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f2093363fd8a3b8386770c72aefa7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f2093363fd8a3b8386770c72aefa7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-try-opt-coercion] More on coercion bindings
by Simon Peyton Jones (＠simonpj) 06 Jan '26
by Simon Peyton Jones (＠simonpj) 06 Jan '26
06 Jan '26
Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC
Commits:
5c1b0929 by Simon Peyton Jones at 2026-01-06T13:43:50+00:00
More on coercion bindings
Allow in letrec; indeed make the invariants for letrec the same
as the invariants for top-level bindings.
ToDo: document this
- - - - -
9 changed files:
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Types/Var/Env.hs
- hadrian/src/Flavour.hs
Changes:
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -445,12 +445,7 @@ opt_co4' env sym rep r (CoVarCo cv)
where
Pair ty1 ty2 = coVarTypes cv1
- cv1 = case lookupInScope (lcInScopeSet env) cv of
- Just cv1 -> cv1
- Nothing -> warnPprTrace True
- "opt_co: not in scope"
- (ppr cv $$ ppr env)
- cv
+ cv1 = refineFromInScope (lcInScopeSet env) cv
-- cv1 might have a substituted kind!
opt_co4' _ _ _ _ (HoleCo h)
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -588,22 +588,8 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
-- Check the let-can-float invariant
-- See Note [Core let-can-float invariant] in GHC.Core
- ; checkL ( isTopLevel top_lvl
- || isJoinId binder
- || mightBeLiftedType binder_ty
- || (isNonRec rec_flag && exprOkForSpeculation rhs)) $
- badBndrTyMsg binder (text "unlifted")
-
- -- Check that if the binder is at the top level the binding
- -- satisfies exprIsTopLevelBindable
- -- See Note [Core top-level string literals].
- ; checkL ( not (isTopLevel top_lvl)
- || exprIsTopLevelBindable rhs binder_ty
- || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed
- ) $
- mkTopNonLitStrMsg binder
-
- ; flags <- getLintFlags
+ ; checkL (bindingIsOk top_lvl rec_flag binder binder_ty rhs) $
+ mkLetErr binder rhs
-- Check that a join-point binder has a valid type
-- NB: lintIdBinder has checked that it is not top-level bound
@@ -612,6 +598,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
JoinPoint arity -> checkL (isValidJoinPointType arity binder_ty)
(mkInvalidJoinPointMsg binder binder_ty)
+ ; flags <- getLintFlags
; when (lf_check_inline_loop_breakers flags
&& isStableUnfolding (realIdUnfolding binder)
&& isStrongLoopBreaker (idOccInfo binder)
@@ -659,6 +646,28 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
-- We should check the unfolding, if any, but this is tricky because
-- the unfolding is a SimplifiableCoreExpr. Give up for now.
+bindingIsOk :: TopLevelFlag -> RecFlag -> OutId -> OutType -> CoreExpr -> Bool
+bindingIsOk top_lvl rec_flag binder binder_ty rhs
+ | isCoVar binder
+ = isCoArg rhs
+
+ | isJoinId binder
+ = not (isTopLevel top_lvl)
+
+ -- Not a JoinId nor a CoVar
+ | isTopLevel top_lvl
+ = exprIsTopLevelBindable rhs binder_ty
+ || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed
+
+ -- So not top level, not JoinId, not CoVar
+ | isRec rec_flag
+ = exprIsTopLevelBindable rhs binder_ty
+
+ -- Not top level, not recursive
+ | otherwise
+ = mightBeLiftedType binder_ty
+ || exprOkForSpeculation rhs
+
-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
@@ -3829,11 +3838,6 @@ mkRhsMsg binder what ty
hsep [text "Binder's type:", ppr (idType binder)],
hsep [text "Rhs type:", ppr ty]]
-badBndrTyMsg :: Id -> SDoc -> SDoc
-badBndrTyMsg binder what
- = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder
- , text "Binder's type:" <+> ppr (idType binder) ]
-
mkNonTopExportedMsg :: Id -> SDoc
mkNonTopExportedMsg binder
= hsep [text "Non-top-level binder is marked as exported:", ppr binder]
@@ -3842,10 +3846,6 @@ mkNonTopExternalNameMsg :: Id -> SDoc
mkNonTopExternalNameMsg binder
= hsep [text "Non-top-level binder has an external name:", ppr binder]
-mkTopNonLitStrMsg :: Id -> SDoc
-mkTopNonLitStrMsg binder
- = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]
-
mkKindErrMsg :: TyVar -> Type -> SDoc
mkKindErrMsg tyvar arg_ty
= vcat [text "Kinds don't match in type application:",
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -624,7 +624,7 @@ reSimplifying :: SimplEnv -> Bool
reSimplifying (SimplEnv { seInlineDepth = n }) = n>0
---------------------
-extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst :: HasDebugCallStack => SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
= assertPpr (isId var && not (isCoVar var)) (ppr var) $
env { seIdSubst = extendVarEnv subst var res }
@@ -934,8 +934,6 @@ addJoinFlts = appOL
mkRecFloats :: SimplFloats -> SimplFloats
-- Flattens the floats into a single Rec group,
-- They must either all be lifted LetFloats or all JoinFloats
---
--- ToDo: explain about CoVar floats
mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
, sfJoinFloats = jbs
, sfInScope = in_scope })
@@ -953,17 +951,7 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
flatten_rec :: OrdList OutBind -> OrdList OutBind
-- Put CoVar bindings first (guaranteed non-recursive)
-- then one recursive value binding
- flatten_rec bs = let !(covar_bs, prs) = foldrOL do_one (nilOL, []) bs
- in covar_bs `snocOL` Rec prs
-
- do_one :: OutBind -> (OrdList OutBind,[(OutId,OutExpr)])
- -> (OrdList OutBind,[(OutId,OutExpr)])
- do_one bind (cvbs, prs)
- = case bind of
- NonRec bndr rhs
- | isCoVar bndr -> (bind `consOL` cvbs, prs)
- | otherwise -> (cvbs, (bndr,rhs):prs)
- Rec prs1 -> (cvbs, prs1 ++ prs)
+ flatten_rec bs = unitOL (Rec (flattenBinds (fromOL bs)))
wrapFloats :: SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression
@@ -1037,14 +1025,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
--
-- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify.
-refineFromInScope :: InScopeSet -> Var -> Var
-refineFromInScope in_scope v
- | isLocalId v = case lookupInScope in_scope v of
- Just v' -> v'
- Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)
- -- c.f #19074 for a subtle place where this went wrong
- | otherwise = v
-
lookupRecBndr :: SimplEnv -> InId -> OutId
-- Look up an Id which has been put into the envt by simplRecBndrs,
-- but where we have not yet done its RHS
@@ -1388,7 +1368,7 @@ substCoVarBndr env cv
(Subst in_scope' _ tv_env' cv_env', cv')
-> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
-substCo :: SimplEnv -> Coercion -> Coercion
+substCo :: HasDebugCallStack => SimplEnv -> Coercion -> Coercion
substCo env co = Coercion.substCo (getTCvSubst env) co
------------------
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -258,11 +258,11 @@ simplRecBind env0 bind_cxt pairs0
= do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt
; return (env', (bndr, bndr', rhs)) }
+ go :: SimplEnv -> [(InId, OutId, InExpr)] -> SimplM (SimplFloats, SimplEnv)
go env [] = return (emptyFloats env, env)
go env ((old_bndr, new_bndr, rhs) : pairs)
- = do { (float, env1) <- simplRecOrTopPair env bind_cxt
- old_bndr new_bndr rhs
+ = do { (float, env1) <- simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
; (floats, env2) <- go env1 pairs
; return (float `addFloats` floats, env2) }
@@ -842,6 +842,10 @@ makeTrivial env top_lvl dmd occ_fs expr
; simplTrace "makeTrivial:co" (ppr (Cast triv_expr triv_co)) $
return (floats1 `addLetFlts` floats2, Cast triv_expr triv_co) }
+ | Coercion co <- expr
+ = do { (floats, triv_co) <- makeCoTrivial co
+ ; return (floats, Coercion triv_co) }
+
| otherwise -- 'expr' is not of form (Cast e co)
= do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr
; uniq <- getUniqueM
@@ -950,12 +954,16 @@ completeBind :: BindContext
-- Binder /can/ be a JoinId
-- Precondition: rhs obeys the let-can-float invariant
completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)
- | isCoVar old_bndr
- = case new_rhs of
- Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)
- _ -> return (mkFloatBind env (NonRec new_bndr new_rhs))
-
- | otherwise
+ | isCoVar old_bndr
+ = case new_rhs of
+ Coercion co -- Inline if it is trivial
+ | postInlineUnconditionally env bind_cxt old_bndr new_bndr new_rhs
+ -> return (emptyFloats env, extendCvSubst env old_bndr co)
+ _otherwise -> -- Can't inline anything other than a Coercion inside a coercion
+ -- So retain the binding insteadd
+ return (mkFloatBind env (NonRec new_bndr new_rhs))
+
+ | otherwise -- Non-CoVars
= assert (isId new_bndr) $
do { let old_info = idInfo old_bndr
old_unf = realUnfoldingInfo old_info
@@ -982,8 +990,8 @@ completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)
return ( emptyFloats env
, extendIdSubst env old_bndr $
DoneEx unf_rhs (idJoinPointHood new_bndr)) }
- -- Use the substitution to make quite, quite sure that the
- -- substitution will happen, since we are going to discard the binding
+ -- Use the substitution to make quite, quite sure that the
+ -- substitution will happen, since we are going to discard the binding
else -- Keep the binding; do cast worker/wrapper
-- simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -59,7 +59,7 @@ import GHC.Core.Opt.Arity
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Opt.Simplify.Monad
-import GHC.Core.Type hiding( substTy )
+import GHC.Core.Type hiding( substTy, extendCvSubst )
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
import GHC.Core.Multiplicity
@@ -1499,7 +1499,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
| not pre_inline_unconditionally = Nothing
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
- | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]
+ | isCoVar bndr, not (isCoArg rhs) = Nothing -- Note [Do not inline CoVars unconditionally]
| isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
-- in module Exitify
| not (one_occ (idOccInfo bndr)) = Nothing
@@ -1511,7 +1511,9 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
| otherwise = Nothing
where
unf = idUnfolding bndr
- extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
+ extend_subst_with inl_rhs
+ | Coercion co <- inl_rhs = extendCvSubst env bndr co
+ | otherwise = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
one_occ OneOcc{ occ_n_br = 1
@@ -1548,15 +1550,16 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
-- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
-- so substituting rhs inside a lambda doesn't change the occ info.
-- Sadly, not quite the same as exprIsHNF.
- canInlineInLam (Lit _) = True
- canInlineInLam (Cast e _) = canInlineInLam e
- canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
- canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e
- canInlineInLam (Var v) = case idOccInfo v of
- OneOcc { occ_in_lam = IsInsideLam } -> True
- ManyOccs {} -> True
- _ -> False
- canInlineInLam _ = False
+ canInlineInLam (Lit _) = True
+ canInlineInLam (Coercion _) = True
+ canInlineInLam (Cast e _) = canInlineInLam e
+ canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
+ canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e
+ canInlineInLam (Var v) = case idOccInfo v of
+ OneOcc { occ_in_lam = IsInsideLam } -> True
+ ManyOccs {} -> True
+ _ -> False
+ canInlineInLam _ = False
-- not ticks. Counting ticks cannot be duplicated, and non-counting
-- ticks around a Lam will disappear anyway.
@@ -1646,7 +1649,6 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs
| isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]
| isTopLevel (bindContextLevel bind_cxt)
= False -- Note [Top level and postInlineUnconditionally]
- | isCoVar bndr = False
| exprIsTrivial rhs = True
| BC_Join {} <- bind_cxt = False -- See point (1) of Note [Duplicating join points]
-- in GHC.Core.Opt.Simplify.Iteration
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -350,7 +350,8 @@ deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synon
where
do_tcv is v = EndoOS do_it
where
- do_it acc | v `elemVarSet` is = acc
+ do_it acc | not (isLocalVar v) = acc
+ | v `elemVarSet` is = acc
| v `elemVarSet` acc = acc
| otherwise = appEndoOS (deep_ty (varType v)) $
acc `extendVarSet` v
@@ -412,7 +413,8 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and sy
where
do_tcv is v = EndoOS do_it
where
- do_it acc | v `elemVarSet` is = acc
+ do_it acc | not (isLocalVar v) = acc
+ | v `elemVarSet` is = acc
| v `elemVarSet` acc = acc
| otherwise = acc `extendVarSet` v
@@ -475,7 +477,8 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView
do_covar is v = EndoOS do_it
where
- do_it acc | v `elemVarSet` is = acc
+ do_it acc | not (isLocalVar v) = acc
+ | v `elemVarSet` is = acc
| v `elemVarSet` acc = acc
| otherwise = appEndoOS (deep_cv_ty (varType v)) $
acc `extendVarSet` v
@@ -706,7 +709,10 @@ tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in
tyCoFVsOfCoVar :: CoVar -> FV
tyCoFVsOfCoVar v fv_cand in_scope acc
+ | isLocalId v
= (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc
+ | otherwise
+ = emptyFV fv_cand in_scope acc
tyCoFVsOfCos :: [Coercion] -> FV
tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2548,8 +2548,10 @@ extendCorePrepEnvList cpe@(CPE { cpe_subst = subst }) prs
subst2 = extendIdSubstList subst1 [(id, Var id') | (id,id') <- prs]
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
+-- The Id can be a CoVar
extendCorePrepEnvExpr cpe id expr
- = cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr }
+ = cpe { cpe_subst = extendSubst (cpe_subst cpe) id expr }
+ -- NB: extendSubst not extendIdSubst; the id can be a CoVar
lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv cpe id
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -55,9 +55,9 @@ module GHC.Types.Var.Env (
-- ** Operations on InScopeSets
emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
- getInScopeVars, lookupInScope, lookupInScope_Directly,
+ lookupInScope, lookupInScope_Directly, refineFromInScope,
unionInScope, elemInScopeSet, uniqAway,
- varSetInScope,
+ varSetInScope, getInScopeVars,
unsafeGetFreshLocalUnique,
-- * The RnEnv2 type
@@ -191,6 +191,14 @@ unionInScope (InScope s1) (InScope s2)
varSetInScope :: VarSet -> InScopeSet -> Bool
varSetInScope vars (InScope s1) = vars `subVarSet` s1
+refineFromInScope :: HasDebugCallStack => InScopeSet -> Var -> Var
+refineFromInScope in_scope v
+ | isLocalVar v = case lookupInScope in_scope v of
+ Just v' -> v'
+ Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)
+ -- c.f #19074 for a subtle place where this went wrong
+ | otherwise = v
+
{-
Note [Local uniques]
~~~~~~~~~~~~~~~~~~~~
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -70,7 +70,8 @@ flavourTransformers = M.fromList
, "fully_static" =: fullyStatic
, "host_fully_static" =: hostFullyStatic
, "collect_timings" =: collectTimings
- , "assertions" =: enableAssertions
+ , "assertions" =: enableAssertions Stage2
+ , "assertions_stage1" =: enableAssertions Stage1
, "debug_ghc" =: debugGhc Stage2
, "debug_stage1_ghc" =: debugGhc Stage1
, "lint" =: enableLinting
@@ -394,11 +395,11 @@ enableLateCCS = addArgs
? arg "-fprof-late"
-- | Enable assertions for the stage2 compiler
-enableAssertions :: Flavour -> Flavour
-enableAssertions flav = flav { ghcDebugAssertions = f }
+enableAssertions :: Stage -> Flavour -> Flavour
+enableAssertions stage flav = flav { ghcDebugAssertions = f }
where
- f Stage2 = True
- f st = ghcDebugAssertions flav st
+ f s | s == stage = True
+ | otherwise = ghcDebugAssertions flav s
-- | Build the stage3 compiler using the non-moving GC.
enableBootNonmovingGc :: Flavour -> Flavour
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c1b0929866b379080e3f33a2aed445…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c1b0929866b379080e3f33a2aed445…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mp/iface-patches-9.10] Migrate `Finder` component to `OsPath`, fixed #24616
by Matthew Pickering (＠mpickering) 06 Jan '26
by Matthew Pickering (＠mpickering) 06 Jan '26
06 Jan '26
Matthew Pickering pushed to branch wip/mp/iface-patches-9.10 at Glasgow Haskell Compiler / GHC
Commits:
4e0739f7 by Fendor at 2026-01-06T12:35:24+00:00
Migrate `Finder` component to `OsPath`, fixed #24616
For each module in a GHCi session, we keep alive one `ModLocation`.
A `ModLocation` is fairly inefficiently packed, as `String`s are
expensive in memory usage.
While benchmarking the agda codebase, we concluded that we keep alive
around 11MB of `FilePath`'s, solely retained by `ModLocation`.
We provide a more densely packed encoding of `ModLocation`, by moving
from `FilePath` to `OsPath`. Further, we migrate the full `Finder`
component to `OsPath` to avoid unnecessary transformations.
As the `Finder` component is well-encapsulated, this requires only a
minimal amount of changes in other modules.
We introduce pattern synonym for 'ModLocation' which maintains backwards
compatibility and avoids breaking consumers of 'ModLocation'.
- - - - -
20 changed files:
- compiler/GHC.hs
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Data/Strict.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/MakeFile/JSON.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -3,7 +3,6 @@
{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE PatternSynonyms #-}
-- -----------------------------------------------------------------------------
@@ -78,6 +77,7 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
+ pattern ModLocation,
getModSummary,
getModuleGraph,
isLoaded,
=====================================
compiler/GHC/Data/OsPath.hs
=====================================
@@ -12,10 +12,14 @@ module GHC.Data.OsPath
, (</>)
, (<.>)
, splitSearchPath
+ , splitExtension
, isRelative
+ , makeRelative
+ , normalise
, dropTrailingPathSeparator
, takeDirectory
- , isSuffixOf
+ , OS.isSuffixOf
+ , OS.drop
, doesDirectoryExist
, doesFileExist
, getDirectoryContents
@@ -31,8 +35,11 @@ import GHC.Utils.Outputable qualified as Outputable
import GHC.Utils.Panic (panic)
import System.OsPath
-import System.OsString (isSuffixOf)
+import qualified System.OsString as OS (isSuffixOf, drop)
import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
+import GHC.Utils.Panic (panic)
+
+import System.OsPath
import System.Directory.Internal (os)
-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
=====================================
compiler/GHC/Data/Strict.hs
=====================================
@@ -9,8 +9,8 @@
module GHC.Data.Strict (
Maybe(Nothing, Just),
fromMaybe,
+ GHC.Data.Strict.maybe,
Pair(And),
-
-- Not used at the moment:
--
-- Either(Left, Right),
@@ -18,6 +18,7 @@ module GHC.Data.Strict (
) where
import GHC.Prelude hiding (Maybe(..), Either(..))
+
import Control.Applicative
import Data.Semigroup
import Data.Data
@@ -29,6 +30,10 @@ fromMaybe :: a -> Maybe a -> a
fromMaybe d Nothing = d
fromMaybe _ (Just x) = x
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe d _ Nothing = d
+maybe _ f (Just x) = f x
+
apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b
apMaybe (Just f) (Just x) = Just (f x)
apMaybe _ _ = Nothing
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -74,6 +74,7 @@ import GHC.Linker.Types
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
+import GHC.Data.OsPath (unsafeEncodeUtf, os)
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.Data.OsPath as OsPath
@@ -775,7 +776,7 @@ summariseRequirement pn mod_name = do
let PackageName pn_fs = pn
let location = mkHomeModLocation2 fopts mod_name
- (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+ (unsafeEncodeUtf $ unpackFS pn_fs </> moduleNameSlashes mod_name) (os "hsig")
env <- getBkpEnv
src_hash <- liftIO $ getFileHash (bkp_filename env)
@@ -859,12 +860,12 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- these filenames to figure out where the hi files go.
-- A travesty!
let location0 = mkHomeModLocation2 fopts modname
- (unpackFS unit_fs </>
+ (unsafeEncodeUtf $ unpackFS unit_fs </>
moduleNameSlashes modname)
(case hsc_src of
- HsigFile -> "hsig"
- HsBootFile -> "hs-boot"
- HsSrcFile -> "hs")
+ HsigFile -> os "hsig"
+ HsBootFile -> os "hs-boot"
+ HsSrcFile -> os "hs")
-- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocnOut location0
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Driver.LlvmConfigCache (LlvmConfigCache)
import GHC.Driver.Ppr
import GHC.Driver.Backend
+import GHC.Data.OsPath (unsafeDecodeUtf)
import qualified GHC.Data.ShortText as ST
import GHC.Data.Stream ( Stream )
import qualified GHC.Data.Stream as Stream
@@ -259,7 +260,7 @@ outputForeignStubs
Maybe FilePath) -- C file created
outputForeignStubs logger tmpfs dflags unit_state mod location stubs
= do
- let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
+ let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
case stubs of
=====================================
compiler/GHC/Driver/Config/Finder.hs
=====================================
@@ -8,27 +8,27 @@ import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Unit.Finder.Types
import GHC.Data.FastString
-
+import GHC.Data.OsPath
-- | Create a new 'FinderOpts' from DynFlags.
initFinderOpts :: DynFlags -> FinderOpts
initFinderOpts flags = FinderOpts
- { finder_importPaths = importPaths flags
+ { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags
, finder_lookupHomeInterfaces = isOneShot (ghcMode flags)
, finder_bypassHiFileCheck = MkDepend == (ghcMode flags)
, finder_ways = ways flags
, finder_enableSuggestions = gopt Opt_HelpfulErrors flags
- , finder_workingDirectory = workingDirectory flags
+ , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags
, finder_thisPackageName = mkFastString <$> thisPackageName flags
, finder_hiddenModules = hiddenModules flags
, finder_reexportedModules = reexportedModules flags
- , finder_hieDir = hieDir flags
- , finder_hieSuf = hieSuf flags
- , finder_hiDir = hiDir flags
- , finder_hiSuf = hiSuf_ flags
- , finder_dynHiSuf = dynHiSuf_ flags
- , finder_objectDir = objectDir flags
- , finder_objectSuf = objectSuf_ flags
- , finder_dynObjectSuf = dynObjectSuf_ flags
- , finder_stubDir = stubDir flags
+ , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags
+ , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags
+ , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags
+ , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags
+ , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags
+ , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags
+ , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags
+ , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags
+ , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -264,6 +264,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.Bag
+import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
@@ -2131,12 +2132,13 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
rawCmms
return stub_c_exists
where
- no_loc = ModLocation{ ml_hs_file = Just original_filename,
- ml_hi_file = panic "hscCompileCmmFile: no hi file",
- ml_obj_file = panic "hscCompileCmmFile: no obj file",
- ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_hie_file = panic "hscCompileCmmFile: no hie file"}
+ no_loc = OsPathModLocation
+ { ml_hs_file_ospath = Just $ unsafeEncodeUtf original_filename,
+ ml_hi_file_ospath = panic "hscCompileCmmFile: no hi file",
+ ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file",
+ ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file",
+ ml_dyn_hi_file_ospath = panic "hscCompileCmmFile: no dyn obj file",
+ ml_hie_file_ospath = panic "hscCompileCmmFile: no hie file"}
-------------------- Stuff for new code gen ---------------------
@@ -2370,12 +2372,13 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
- let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
- ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
- ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
- ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
- ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
+ let iNTERACTIVELoc = OsPathModLocation
+ { ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = panic "hsDeclsWithLocation:ml_hi_file_ospath",
+ ml_obj_file_ospath = panic "hsDeclsWithLocation:ml_obj_file_ospath",
+ ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath",
+ ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath",
+ ml_hie_file_ospath = panic "hsDeclsWithLocation:ml_hie_file_ospath" }
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
{- Simplify -}
@@ -2655,12 +2658,13 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Lint if necessary -}
lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr
- let this_loc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
- ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
- ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
- ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file",
- ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
+ let this_loc = OsPathModLocation
+ { ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = panic "hscCompileCoreExpr':ml_hi_file_ospath",
+ ml_obj_file_ospath = panic "hscCompileCoreExpr':ml_obj_file_ospath",
+ ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath",
+ ml_dyn_hi_file_ospath = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath",
+ ml_hie_file_ospath = panic "hscCompileCoreExpr':ml_hie_file_ospath" }
-- Ensure module uniqueness by giving it a name like "GhciNNNN".
-- This uniqueness is needed by the JS linker. Without it we break the 1-1
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -79,6 +79,7 @@ import GHC.Data.Bag ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
+import GHC.Data.OsPath ( unsafeEncodeUtf )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
@@ -1913,7 +1914,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
let dyn_tn = tn -<.> dynsuf
addFilesToClean tmpfs dynLife [dyn_tn]
- return (tn, dyn_tn)
+ return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
-- the ModSummary with temporary files.
@@ -1922,8 +1923,8 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
-- If ``-fwrite-interface` is specified, then the .o and .hi files
-- are written into `-odir` and `-hidir` respectively. #16670
if gopt Opt_WriteInterface dflags
- then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
- , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
+ then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location)
+ , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))
else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
<*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
let new_dflags = case enable_spec of
@@ -1932,10 +1933,10 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
let ms' = ms
{ ms_location =
- ms_location { ml_hi_file = hi_file
- , ml_obj_file = o_file
- , ml_dyn_hi_file = dyn_hi_file
- , ml_dyn_obj_file = dyn_o_file }
+ ms_location { ml_hi_file_ospath = hi_file
+ , ml_obj_file_ospath = o_file
+ , ml_dyn_hi_file_ospath = dyn_hi_file
+ , ml_dyn_obj_file_ospath = dyn_o_file }
, ms_hspp_opts = updOptLevel 0 $ new_dflags
}
-- Recursive call to catch the other cases
@@ -2121,7 +2122,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
let fopts = initFinderOpts (hsc_dflags hsc_env)
-- Make a ModLocation for this file
- let location = mkHomeModLocation fopts pi_mod_name src_fn
+ let location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf src_fn)
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -32,6 +32,8 @@ import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile))
import GHC.Driver.Session (pgm_F)
import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
+import GHC.Data.OsPath (unsafeDecodeUtf, OsPath, OsString)
+import qualified GHC.Data.OsPath as OS
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SourceError
@@ -243,15 +245,15 @@ processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode
updateJson m_dep_json (updateDepJSON include_pkg_deps pp dep_node deps)
writeDependencies include_pkg_deps root hdl extra_suffixes dep_node deps
where
- extra_suffixes = depSuffixes dflags
+ extra_suffixes = map OS.os (depSuffixes dflags)
include_pkg_deps = depIncludePkgDeps dflags
- src_file = msHsFilePath node
+ src_file = msHsFileOsPath node
dep_node =
DepNode {
dn_mod = ms_mod node,
dn_src = src_file,
- dn_obj = msObjFilePath node,
- dn_hi = msHiFilePath node,
+ dn_obj = msObjFileOsPath node,
+ dn_hi = msHiFileOsPath node,
dn_boot = isBootSummary node,
dn_options = Set.fromList (ms_opts node)
}
@@ -285,7 +287,7 @@ processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode
cpp_deps = do
session <- Session <$> newIORef hsc_env
parsedMod <- reflectGhc (GHC.parseModule node) session
- pure (DepCpp <$> GHC.pm_extra_src_files parsedMod)
+ pure (DepCpp . OS.os <$> GHC.pm_extra_src_files parsedMod)
-- Emit a dependency for each import
import_deps is_boot idecls =
@@ -309,7 +311,7 @@ findDependency hsc_env srcloc pkg imp dep_boot = do
Found loc dep_mod ->
pure DepHi {
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,
dep_boot
@@ -329,7 +331,7 @@ writeDependencies ::
Bool ->
FilePath ->
Handle ->
- [FilePath] ->
+ [OsString] ->
DepNode ->
[Dep] ->
IO ()
@@ -373,7 +375,7 @@ writeDependencies include_pkgs root hdl suffixes node deps =
DepNode {dn_src, dn_obj, dn_hi, dn_boot} = node
-----------------------------
-writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
+writeDependency :: FilePath -> Handle -> [OsPath] -> OsPath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
-- t1 t2 : dep
writeDependency root hdl targets dep
@@ -381,25 +383,25 @@ 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' = OS.makeRelative (OS.os root) dep
+ forOutput = escapeSpaces . reslash Forwards . unsafeDecodeUtf . OS.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 OS.<.> (extra `mappend` suffix) | extra <- extras ]
where
- (basename, suffix) = case splitExtension file_name of
+ (basename, suffix) = case OS.splitExtension file_name of
-- Drop the "." from the extension
- (b, s) -> (b, drop 1 s)
+ (b, s) -> (b, OS.drop 1 s)
-----------------------------------------------------------------
=====================================
compiler/GHC/Driver/MakeFile/JSON.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Unit
import GHC.Utils.Json
import GHC.Utils.Misc
import GHC.Utils.Outputable
-import System.FilePath (normalise)
+import GHC.Data.OsPath
--------------------------------------------------------------------------------
-- Output helpers
@@ -92,9 +92,9 @@ writeJsonOutput =
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_options :: Set.Set String
}
@@ -102,14 +102,14 @@ data DepNode =
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
}
--------------------------------------------------------------------------------
@@ -125,10 +125,10 @@ instance Semigroup PackageDeps where
data Deps =
Deps {
- sources :: Set.Set FilePath,
+ sources :: Set.Set OsPath,
modules :: (Set.Set ModuleName, Set.Set ModuleName),
packages :: PackageDeps,
- cpp :: Set.Set FilePath,
+ cpp :: Set.Set OsPath,
options :: Set.Set String,
preprocessor :: Maybe FilePath
}
@@ -141,7 +141,7 @@ instance ToJson DepJSON where
json (DepJSON m) =
JSObject [
(moduleNameString target, JSObject [
- ("sources", array sources normalise),
+ ("sources", array sources (unsafeDecodeUtf . normalise)),
("modules", array (fst modules) moduleNameString),
("modules-boot", array (snd modules) moduleNameString),
("packages",
@@ -150,7 +150,7 @@ instance ToJson DepJSON where
((name, unit_id, package_id), mods) <- Map.toList packages
]
),
- ("cpp", array cpp id),
+ ("cpp", array cpp unsafeDecodeUtf),
("options", array options id),
("preprocessor", maybe JSNull JSString preprocessor)
])
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Iface.Make
import GHC.Driver.Config.Parser
import GHC.Parser.Header
import GHC.Data.StringBuffer
+import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Types.SourceError
import GHC.Unit.Finder
import Data.IORef
@@ -772,7 +773,7 @@ mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO Mod
mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
let PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
- let location1 = mkHomeModLocation2 fopts mod_name basename suff
+ let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-- Boot-ify it if necessary
let location2
@@ -784,11 +785,11 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
- location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+ location3 | Just fn <- ohi = location2{ ml_hi_file_ospath = unsafeEncodeUtf fn }
| otherwise = location2
let dynohi = dynOutputHi dflags
- location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
+ location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
| otherwise = location3
-- Take -o into account if present
@@ -802,10 +803,10 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
location5 | Just ofile <- expl_o_file
, let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
, isNoLink (ghcLink dflags)
- = location4 { ml_obj_file = ofile
- , ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_obj_file_ospath = unsafeEncodeUtf ofile
+ , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| Just dyn_ofile <- expl_dyn_o_file
- = location4 { ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| otherwise = location4
return location5
where
=====================================
compiler/GHC/Iface/Errors.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.Utils.Panic.Plain
import GHC.Driver.DynFlags
import GHC.Driver.Env
import GHC.Data.Maybe
+import GHC.Data.OsPath
import GHC.Prelude
import GHC.Unit
import GHC.Unit.Env
@@ -55,13 +56,13 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg
, notHomeUnitId mhome_unit pkg
- -> not_found_in_package pkg files
+ -> not_found_in_package pkg $ fmap unsafeDecodeUtf files
| null files
-> NotAModule
| otherwise
- -> CouldntFindInFiles files
+ -> CouldntFindInFiles $ fmap unsafeDecodeUtf files
_ -> panic "cantFindInstalledErr"
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -43,6 +43,9 @@ import GHC.Platform.Ways
import GHC.Builtin.Names ( gHC_PRIM )
+import GHC.Data.Maybe ( expectJust )
+import GHC.Data.OsPath
+
import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module
@@ -50,7 +53,6 @@ import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
-import GHC.Data.Maybe ( expectJust )
import qualified GHC.Data.ShortText as ST
import GHC.Utils.Misc
@@ -62,8 +64,7 @@ import GHC.Types.PkgQual
import GHC.Fingerprint
import Data.IORef
-import System.Directory
-import System.FilePath
+import System.Directory.OsPath
import Control.Monad
import Data.Time
import qualified Data.Map as M
@@ -72,9 +73,10 @@ import GHC.Driver.Env
import GHC.Driver.Config.Finder
import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
import qualified Data.Set as Set
+import qualified System.OsPath as OsPath
-type FileExt = String -- Filename extension
-type BaseName = String -- Basename of file
+type FileExt = OsString -- Filename extension
+type BaseName = OsPath -- Basename of file
-- -----------------------------------------------------------------------------
-- The Finder
@@ -327,7 +329,7 @@ findLookupResult fc fopts r = case r of
-- implicit locations from the instances
InstalledFound loc _ -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
- InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)
+ InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
, fr_mods_hidden = []
, fr_unusables = []
@@ -398,7 +400,7 @@ findHomeModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -423,7 +425,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -459,17 +461,17 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
hi_dir_path =
case finder_hiDir fopts of
Just hiDir -> case maybe_working_dir of
- Nothing -> [hiDir]
- Just fp -> [fp </> hiDir]
+ Nothing -> [hiDir]
+ Just fp -> [fp </> hiDir]
Nothing -> home_path
hisuf = finder_hiSuf fopts
mod = mkModule home_unit mod_name
source_exts =
- [ ("hs", mkHomeModLocationSearched fopts mod_name "hs")
- , ("lhs", mkHomeModLocationSearched fopts mod_name "lhs")
- , ("hsig", mkHomeModLocationSearched fopts mod_name "hsig")
- , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")
+ [ (os "hs", mkHomeModLocationSearched fopts mod_name $ os "hs")
+ , (os "lhs", mkHomeModLocationSearched fopts mod_name $ os "lhs")
+ , (os "hsig", mkHomeModLocationSearched fopts mod_name $ os "hsig")
+ , (os "lhsig", mkHomeModLocationSearched fopts mod_name $ os "lhsig")
]
-- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
@@ -494,10 +496,11 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
-augmentImports :: FilePath -> [FilePath] -> [FilePath]
+augmentImports :: OsPath -> [OsPath] -> [OsPath]
augmentImports _work_dir [] = []
-augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps
- | otherwise = (work_dir </> fp) : augmentImports work_dir fps
+augmentImports work_dir (fp:fps)
+ | OsPath.isAbsolute fp = fp : augmentImports work_dir fps
+ | otherwise = (work_dir </> fp) : augmentImports work_dir fps
-- | Search for a module in external packages only.
findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
@@ -529,14 +532,14 @@ findPackageModule_ fc fopts mod pkg_conf = do
tag = waysBuildTag (finder_ways fopts)
-- hi-suffix for packages depends on the build tag.
- package_hisuf | null tag = "hi"
- | otherwise = tag ++ "_hi"
+ package_hisuf | null tag = os "hi"
+ | otherwise = os (tag ++ "_hi")
- package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
+ package_dynhisuf = os $ waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf
- import_dirs = map ST.unpack $ unitImportDirs pkg_conf
+ import_dirs = map (unsafeEncodeUtf . ST.unpack) $ unitImportDirs pkg_conf
-- we never look for a .hi-boot file in an external package;
-- .hi-boot files only make sense for the home package.
in
@@ -544,7 +547,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
[one] | finder_bypassHiFileCheck fopts ->
-- there's only one place that this .hi file can be, so
-- don't bother looking for it.
- let basename = moduleNameSlashes (moduleName mod)
+ let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
in return $ InstalledFound loc mod
_otherwise ->
@@ -553,24 +556,24 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- -----------------------------------------------------------------------------
-- General path searching
-searchPathExts :: [FilePath] -- paths to search
+searchPathExts :: [OsPath] -- paths to search
-> InstalledModule -- module name
-> [ (
- FileExt, -- suffix
- FilePath -> BaseName -> ModLocation -- action
+ FileExt, -- suffix
+ OsPath -> BaseName -> ModLocation -- action
)
]
-> IO InstalledFindResult
searchPathExts paths mod exts = search to_search
where
- basename = moduleNameSlashes (moduleName mod)
+ basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
- to_search :: [(FilePath, ModLocation)]
+ to_search :: [(OsPath, ModLocation)]
to_search = [ (file, fn path basename)
| path <- paths,
(ext,fn) <- exts,
- let base | path == "." = basename
+ let base | path == os "." = basename
| otherwise = path </> basename
file = base <.> ext
]
@@ -584,7 +587,7 @@ searchPathExts paths mod exts = search to_search
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
- -> FilePath -> BaseName -> ModLocation
+ -> OsPath -> BaseName -> ModLocation
mkHomeModLocationSearched fopts mod suff path basename =
mkHomeModLocation2 fopts mod (path </> basename) suff
@@ -622,18 +625,18 @@ mkHomeModLocationSearched fopts mod suff path basename =
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
mkHomeModLocation dflags mod src_filename =
- let (basename,extension) = splitExtension src_filename
+ let (basename,extension) = OsPath.splitExtension src_filename
in mkHomeModLocation2 dflags mod basename extension
mkHomeModLocation2 :: FinderOpts
-> ModuleName
- -> FilePath -- Of source module, without suffix
- -> String -- Suffix
+ -> OsPath -- Of source module, without suffix
+ -> FileExt -- Suffix
-> ModLocation
mkHomeModLocation2 fopts mod src_basename ext =
- let mod_basename = moduleNameSlashes mod
+ let mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
obj_fn = mkObjPath fopts src_basename mod_basename
dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename
@@ -641,51 +644,51 @@ mkHomeModLocation2 fopts mod src_basename ext =
dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename
hie_fn = mkHiePath fopts src_basename mod_basename
- in (ModLocation{ ml_hs_file = Just (src_basename <.> ext),
- ml_hi_file = hi_fn,
- ml_dyn_hi_file = dyn_hi_fn,
- ml_obj_file = obj_fn,
- ml_dyn_obj_file = dyn_obj_fn,
- ml_hie_file = hie_fn })
+ in (OsPathModLocation{ ml_hs_file_ospath = Just (src_basename <.> ext),
+ ml_hi_file_ospath = hi_fn,
+ ml_dyn_hi_file_ospath = dyn_hi_fn,
+ ml_obj_file_ospath = obj_fn,
+ ml_dyn_obj_file_ospath = dyn_obj_fn,
+ ml_hie_file_ospath = hie_fn })
mkHomeModHiOnlyLocation :: FinderOpts
-> ModuleName
- -> FilePath
+ -> OsPath
-> BaseName
-> ModLocation
mkHomeModHiOnlyLocation fopts mod path basename =
- let loc = mkHomeModLocation2 fopts mod (path </> basename) ""
- in loc { ml_hs_file = Nothing }
+ let loc = mkHomeModLocation2 fopts mod (path </> basename) mempty
+ in loc { ml_hs_file_ospath = Nothing }
-- This function is used to make a ModLocation for a package module. Hence why
-- we explicitly pass in the interface file suffixes.
-mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String
+mkHiOnlyModLocation :: FinderOpts -> FileExt -> FileExt -> OsPath -> OsPath
-> ModLocation
mkHiOnlyModLocation fopts hisuf dynhisuf path basename
= let full_basename = path </> basename
obj_fn = mkObjPath fopts full_basename basename
dyn_obj_fn = mkDynObjPath fopts full_basename basename
hie_fn = mkHiePath fopts full_basename basename
- in ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = full_basename <.> hisuf,
- -- Remove the .hi-boot suffix from
- -- hi_file, if it had one. We always
- -- want the name of the real .hi file
- -- in the ml_hi_file field.
- ml_dyn_obj_file = dyn_obj_fn,
- -- MP: TODO
- ml_dyn_hi_file = full_basename <.> dynhisuf,
- ml_obj_file = obj_fn,
- ml_hie_file = hie_fn
+ in OsPathModLocation{ ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = full_basename <.> hisuf,
+ -- Remove the .hi-boot suffix from
+ -- hi_file, if it had one. We always
+ -- want the name of the real .hi file
+ -- in the ml_hi_file field.
+ ml_dyn_obj_file_ospath = dyn_obj_fn,
+ -- MP: TODO
+ ml_dyn_hi_file_ospath = full_basename <.> dynhisuf,
+ ml_obj_file_ospath = obj_fn,
+ ml_hie_file_ospath = hie_fn
}
-- | Constructs the filename of a .o file for a given source file.
-- Does /not/ check whether the .o file exists
mkObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkObjPath fopts basename mod_basename = obj_basename <.> osuf
where
odir = finder_objectDir fopts
@@ -698,9 +701,9 @@ mkObjPath fopts basename mod_basename = obj_basename <.> osuf
-- Does /not/ check whether the .dyn_o file exists
mkDynObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
where
odir = finder_objectDir fopts
@@ -714,9 +717,9 @@ mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
-- Does /not/ check whether the .hi file exists
mkHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
where
hidir = finder_hiDir fopts
@@ -729,9 +732,9 @@ mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
-- Does /not/ check whether the .dyn_hi file exists
mkDynHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
where
hidir = finder_hiDir fopts
@@ -744,9 +747,9 @@ mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
-- Does /not/ check whether the .hie file exists
mkHiePath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf
where
hiedir = finder_hieDir fopts
@@ -767,23 +770,23 @@ mkStubPaths
:: FinderOpts
-> ModuleName
-> ModLocation
- -> FilePath
+ -> OsPath
mkStubPaths fopts mod location
= let
stubdir = finder_stubDir fopts
- mod_basename = moduleNameSlashes mod
- src_basename = dropExtension $ expectJust "mkStubPaths"
- (ml_hs_file location)
+ mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
+ src_basename = OsPath.dropExtension $ expectJust "mkStubPaths"
+ (ml_hs_file_ospath location)
stub_basename0
| Just dir <- stubdir = dir </> mod_basename
| otherwise = src_basename
- stub_basename = stub_basename0 ++ "_stub"
+ stub_basename = stub_basename0 `mappend` os "_stub"
in
- stub_basename <.> "h"
+ stub_basename <.> os "h"
-- -----------------------------------------------------------------------------
-- findObjectLinkable isn't related to the other stuff in here,
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -9,6 +9,7 @@ where
import GHC.Prelude
import GHC.Unit
+import GHC.Data.OsPath
import qualified Data.Map as M
import GHC.Fingerprint
import GHC.Platform.Ways
@@ -31,7 +32,7 @@ data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)
data InstalledFindResult
= InstalledFound ModLocation InstalledModule
| InstalledNoPackage UnitId
- | InstalledNotFound [FilePath] (Maybe UnitId)
+ | InstalledNotFound [OsPath] (Maybe UnitId)
-- | The result of searching for an imported module.
--
@@ -70,7 +71,7 @@ data FindResult
--
-- Should be taken from 'DynFlags' via 'initFinderOpts'.
data FinderOpts = FinderOpts
- { finder_importPaths :: [FilePath]
+ { finder_importPaths :: [OsPath]
-- ^ Where are we allowed to look for Modules and Source files
, finder_lookupHomeInterfaces :: Bool
-- ^ When looking up a home module:
@@ -88,17 +89,17 @@ data FinderOpts = FinderOpts
, finder_enableSuggestions :: Bool
-- ^ If we encounter unknown modules, should we suggest modules
-- that have a similar name.
- , finder_workingDirectory :: Maybe FilePath
+ , finder_workingDirectory :: Maybe OsPath
, finder_thisPackageName :: Maybe FastString
, finder_hiddenModules :: Set.Set ModuleName
, finder_reexportedModules :: Set.Set ModuleName
- , finder_hieDir :: Maybe FilePath
- , finder_hieSuf :: String
- , finder_hiDir :: Maybe FilePath
- , finder_hiSuf :: String
- , finder_dynHiSuf :: String
- , finder_objectDir :: Maybe FilePath
- , finder_objectSuf :: String
- , finder_dynObjectSuf :: String
- , finder_stubDir :: Maybe FilePath
+ , finder_hieDir :: Maybe OsPath
+ , finder_hieSuf :: OsString
+ , finder_hiDir :: Maybe OsPath
+ , finder_hiSuf :: OsString
+ , finder_dynHiSuf :: OsString
+ , finder_objectDir :: Maybe OsPath
+ , finder_objectSuf :: OsString
+ , finder_dynObjectSuf :: OsString
+ , finder_stubDir :: Maybe OsPath
} deriving Show
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -1,6 +1,17 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Module location
module GHC.Unit.Module.Location
- ( ModLocation(..)
+ ( ModLocation
+ ( ..
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ )
+ , pattern ModLocation
, addBootSuffix
, addBootSuffix_maybe
, addBootSuffixLocn_maybe
@@ -11,15 +22,19 @@ module GHC.Unit.Module.Location
where
import GHC.Prelude
+
+import GHC.Data.OsPath
import GHC.Unit.Types
import GHC.Utils.Outputable
+import qualified System.OsString as OsString
+
-- | Module Location
--
-- Where a module lives on the file system: the actual locations
-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them.
--
--- For a module in another unit, the ml_hs_file and ml_obj_file components of
+-- For a module in another unit, the ml_hs_file_ospath and ml_obj_file_ospath components of
-- ModLocation are undefined.
--
-- The locations specified by a ModLocation may or may not
@@ -38,31 +53,31 @@ import GHC.Utils.Outputable
-- boot suffixes in mkOneShotModLocation.
data ModLocation
- = ModLocation {
- ml_hs_file :: Maybe FilePath,
+ = OsPathModLocation {
+ ml_hs_file_ospath :: Maybe OsPath,
-- ^ The source file, if we have one. Package modules
-- probably don't have source files.
- ml_hi_file :: FilePath,
+ ml_hi_file_ospath :: OsPath,
-- ^ Where the .hi file is, whether or not it exists
-- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later)
- ml_dyn_hi_file :: FilePath,
+ ml_dyn_hi_file_ospath :: OsPath,
-- ^ Where the .dyn_hi file is, whether or not it exists
-- yet.
- ml_obj_file :: FilePath,
+ ml_obj_file_ospath :: OsPath,
-- ^ Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- unit with a .a file)
- ml_dyn_obj_file :: FilePath,
+ ml_dyn_obj_file_ospath :: OsPath,
-- ^ Where the .dy file is, whether or not it exists
-- yet.
- ml_hie_file :: FilePath
+ ml_hie_file_ospath :: OsPath
-- ^ Where the .hie file is, whether or not it exists
-- yet.
} deriving Show
@@ -71,18 +86,18 @@ instance Outputable ModLocation where
ppr = text . show
-- | Add the @-boot@ suffix to .hs, .hi and .o files
-addBootSuffix :: FilePath -> FilePath
-addBootSuffix path = path ++ "-boot"
+addBootSuffix :: OsPath -> OsPath
+addBootSuffix path = path `mappend` os "-boot"
-- | Remove the @-boot@ suffix to .hs, .hi and .o files
-removeBootSuffix :: FilePath -> FilePath
-removeBootSuffix "-boot" = []
-removeBootSuffix (x:xs) = x : removeBootSuffix xs
-removeBootSuffix [] = error "removeBootSuffix: no -boot suffix"
-
+removeBootSuffix :: OsPath -> OsPath
+removeBootSuffix pathWithBootSuffix =
+ case OsString.stripSuffix (os "-boot") pathWithBootSuffix of
+ Just path -> path
+ Nothing -> error "removeBootSuffix: no -boot suffix"
-- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath
+addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
addBootSuffix_maybe is_boot path = case is_boot of
IsBoot -> addBootSuffix path
NotBoot -> path
@@ -95,22 +110,50 @@ addBootSuffixLocn_maybe is_boot locn = case is_boot of
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
- = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
- , ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn) }
+ = locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn)
+ , ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
+ , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
+ , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
+ , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
+ , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) }
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut :: ModLocation -> ModLocation
addBootSuffixLocnOut locn
- = locn { ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn)
+ = locn { ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
+ , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
+ , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
+ , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
+ , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn)
}
-
+-- ----------------------------------------------------------------------------
+-- Helpers for backwards compatibility
+-- ----------------------------------------------------------------------------
+
+pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation
+pattern ModLocation
+ { ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ } <- OsPathModLocation
+ { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file)
+ , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file)
+ , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file)
+ , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file)
+ , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file)
+ , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file)
+ } where
+ ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file
+ = OsPathModLocation
+ { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file
+ , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file
+ , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file
+ , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file
+ , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file
+ , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file
+ }
=====================================
compiler/GHC/Unit/Module/ModSummary.hs
=====================================
@@ -17,6 +17,11 @@ module GHC.Unit.Module.ModSummary
, msHsFilePath
, msObjFilePath
, msDynObjFilePath
+ , msHsFileOsPath
+ , msHiFileOsPath
+ , msDynHiFileOsPath
+ , msObjFileOsPath
+ , msDynObjFileOsPath
, msDeps
, isBootSummary
, findTarget
@@ -38,6 +43,7 @@ import GHC.Types.Target
import GHC.Types.PkgQual
import GHC.Data.Maybe
+import GHC.Data.OsPath (OsPath)
import GHC.Data.StringBuffer ( StringBuffer )
import GHC.Utils.Fingerprint
@@ -148,6 +154,13 @@ msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms)
+msHsFileOsPath, msDynHiFileOsPath, msHiFileOsPath, msObjFileOsPath, msDynObjFileOsPath :: ModSummary -> OsPath
+msHsFileOsPath ms = expectJust "msHsFilePath" (ml_hs_file_ospath (ms_location ms))
+msHiFileOsPath ms = ml_hi_file_ospath (ms_location ms)
+msDynHiFileOsPath ms = ml_dyn_hi_file_ospath (ms_location ms)
+msObjFileOsPath ms = ml_obj_file_ospath (ms_location ms)
+msDynObjFileOsPath ms = ml_dyn_obj_file_ospath (ms_location ms)
+
-- | Did this 'ModSummary' originate from a hs-boot file?
isBootSummary :: ModSummary -> IsBootInterface
isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot
=====================================
compiler/ghc.cabal.in
=====================================
@@ -117,6 +117,7 @@ Library
filepath >= 1 && < 1.6,
os-string >= 2.0.1 && < 2.1,
template-haskell == 2.22.*,
+ os-string >= 2.0.1 && < 2.1,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
exceptions == 0.10.*,
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -36,7 +36,7 @@ Executable ghc
bytestring >= 0.9 && < 0.13,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
- filepath >= 1 && < 1.6,
+ filepath >= 1.5 && < 1.6,
containers >= 0.5 && < 0.8,
transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -70,6 +70,7 @@ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Strict
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -71,6 +71,7 @@ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Strict
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e0739f7331069d93220c627b72c28a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e0739f7331069d93220c627b72c28a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed new branch wip/T26724 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26724
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-clang64-split-sections] 6 commits: hadrian: drops unused PE linker script for windows
by Cheng Shao (＠TerrorJack) 06 Jan '26
by Cheng Shao (＠TerrorJack) 06 Jan '26
06 Jan '26
Cheng Shao pushed to branch wip/fix-clang64-split-sections at Glasgow Haskell Compiler / GHC
Commits:
a8a94aad by Cheng Shao at 2026-01-05T16:24:04-05:00
hadrian: drops unused PE linker script for windows
This patch drops unused PE linker script for windows in the
`MergeObjects` builder of hadrian. The linker script is used for
merging object files into a single `HS*.o` object file and undoing the
effect of split sections, when building the "ghci library" object
file. However, we don't build the ghci library on windows, and this
code path is actually unreachable.
- - - - -
53038ea9 by Cheng Shao at 2026-01-05T16:24:04-05:00
hadrian: drop unused logic for building ghci libraries
This patch drops the unused logic for building ghci libraries in
hadrian:
- The term "ghci library" refers to an optional object file per
library `HS*.o`, which is merged from multiple object files in that
library using the `MergeObjects` builder in hadrian.
- The original rationale of having a ghci library object, in addition
to normal archives, was to speedup ghci loading, since the combined
object is linked with a linker script to undo the effects of
`-fsplit-sections` to reduce section count and make it easier for
the RTS linker to handle.
- However, most GHC builds enable `dynamicGhcPrograms` by default, in
such cases the ghci library would already not be built.
- `dynamicGhcPrograms` is disabled on Windows, but still we don't
build the ghci library due to lack of functioning merge objects
command.
- The only case that we actually build ghci library objects, are
alpine fully static bindists. However, for other reasons, split
sections is already disabled for fully static builds anyway!
- There will not be any regression if the ghci library objects are
absent from a GHC global libdir when `dynamicGhcPrograms` is
disabled. The RTS linker can already load the archives without any
issue.
Hence the removal. We now forcibly disable ghci libraries for all
Cabal components, and rip out all logic related to `MergeObjects` and
ghci libraries in hadrian. This also nicely cleans up some old todos
and fixmes that are no longer relevant.
Note that MergeObjects in hadrian is not the same thing as merge
objects in the GHC driver. The latter is not affected by this patch.
-------------------------
Metric Decrease:
libdir
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
8f209336 by Simon Jakobi at 2026-01-05T16:24:48-05:00
User's guide: Fix link to language extensions
Instead of linking to haddocks, it seemed more useful to link
to the extension overview in the user's guide.
Closes #26614.
- - - - -
b19130a9 by Cheng Shao at 2026-01-06T10:35:20+01:00
compiler: change sectionProtection to take SectionType argument
This commit changes `sectionProtection` to only take `SectionType`
argument instead of whole `Section`, since it doesn't need the Cmm
section content anyway, and it can then be called in parts of NCG
where we only have a `SectionType` in scope.
- - - - -
85544821 by Cheng Shao at 2026-01-06T10:35:20+01:00
compiler: change isInitOrFiniSection to take SectionType argument
This commit changes `isInitOrFiniSection` to only take `SectionType`
argument instead of whole `Section`, since it doesn't need the Cmm
section content anyway, and it can then be called in parts of NCG
where we only have a `SectionType` in scope. Also marks it as
exported.
- - - - -
17030d83 by Cheng Shao at 2026-01-06T10:35:20+01:00
compiler: fix split sections on windows
This patch fixes split sections on windows by emitting the right
COMDAT section header in NCG, see added comment for more explanation.
Fix #26696 #26494.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
27 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/InitFini.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/Data.hs
- docs/users_guide/exts/pragmas.rst
- docs/users_guide/exts/table.rst
- − driver/utils/merge_sections.ld
- − driver/utils/merge_sections_pe.ld
- hadrian/hadrian.cabal
- hadrian/src/Builder.hs
- hadrian/src/Context.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Hadrian/Haskell/Cabal/Type.hs
- hadrian/src/Hadrian/Haskell/Hash.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Settings/Builders/Cabal.hs
- − hadrian/src/Settings/Builders/MergeObjects.hs
- hadrian/src/Settings/Builders/SplitSections.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -278,8 +278,8 @@ data SectionProtection
deriving (Eq)
-- | Should a data in this section be considered constant at runtime
-sectionProtection :: Section -> SectionProtection
-sectionProtection (Section t _) = case t of
+sectionProtection :: SectionType -> SectionProtection
+sectionProtection t = case t of
Text -> ReadOnlySection
ReadOnlyData -> ReadOnlySection
RelocatableReadOnlyData -> WriteProtectedSection
=====================================
compiler/GHC/Cmm/InitFini.hs
=====================================
@@ -2,6 +2,7 @@
module GHC.Cmm.InitFini
( InitOrFini(..)
, isInitOrFiniArray
+ , isInitOrFiniSection
) where
import GHC.Prelude
@@ -63,8 +64,8 @@ finalizer CmmDecl will be emitted per module.
data InitOrFini = IsInitArray | IsFiniArray
isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel])
-isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits))
- | Just initOrFini <- isInitOrFiniSection sect
+isInitOrFiniArray (CmmData (Section t _) (CmmStaticsRaw _ lits))
+ | Just initOrFini <- isInitOrFiniSection t
= Just (initOrFini, map get_label lits)
where
get_label :: CmmStatic -> CLabel
@@ -72,7 +73,7 @@ isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits))
get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static)
isInitOrFiniArray _ = Nothing
-isInitOrFiniSection :: Section -> Maybe InitOrFini
-isInitOrFiniSection (Section InitArray _) = Just IsInitArray
-isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray
+isInitOrFiniSection :: SectionType -> Maybe InitOrFini
+isInitOrFiniSection InitArray = Just IsInitArray
+isInitOrFiniSection FiniArray = Just IsFiniArray
isInitOrFiniSection _ = Nothing
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
+import GHC.Cmm.InitFini
import GHC.Types.Unique ( pprUniqueAlways, getUnique )
import GHC.Platform
@@ -28,9 +29,7 @@ import GHC.Utils.Panic
pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
- let platform = ncgPlatform config
- in
- pprSectionAlign config section $$ pprDatas platform dats
+ pprSectionAlign config section $$ pprDatas config dats
pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
let platform = ncgPlatform config
@@ -91,9 +90,20 @@ pprAlignForSection _platform _seg
-- .balign 8
--
pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
-pprSectionAlign config sec@(Section seg _) =
+pprSectionAlign config sec@(Section seg suffix) =
line (pprSectionHeader config sec)
+ $$ coffSplitSectionComdatKey
$$ pprAlignForSection (ncgPlatform config) seg
+ where
+ platform = ncgPlatform config
+ -- See Note [Split sections on COFF objects]
+ coffSplitSectionComdatKey
+ | OSMinGW32 <- platformOS platform
+ , ncgSplitSections config
+ , Nothing <- isInitOrFiniSection seg
+ = line (pprCOFFComdatKey platform suffix <> colon)
+ | otherwise
+ = empty
-- | Output the ELF .size directive.
pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
@@ -136,20 +146,26 @@ pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs)
(l@LOCATION{} : _) -> pprInstr platform l
_other -> empty
-pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc
+pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
+ -- See Note [Split sections on COFF objects]
+ , not $ platformOS platform == OSMinGW32 && ncgSplitSections config
= pprGloblDecl platform alias
$$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind')
+ where
+ platform = ncgPlatform config
-pprDatas platform (CmmStaticsRaw lbl dats)
+pprDatas config (CmmStaticsRaw lbl dats)
= vcat (pprLabel platform lbl : map (pprData platform) dats)
+ where
+ platform = ncgPlatform config
pprData :: IsDoc doc => Platform -> CmmStatic -> doc
pprData _platform (CmmString str) = line (pprString str)
=====================================
compiler/GHC/CmmToAsm/Ppr.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiWayIf #-}
-----------------------------------------------------------------------------
--
@@ -14,6 +15,7 @@ module GHC.CmmToAsm.Ppr (
pprASCII,
pprString,
pprFileEmbed,
+ pprCOFFComdatKey,
pprSectionHeader
)
@@ -23,6 +25,7 @@ import GHC.Prelude
import GHC.Utils.Asm
import GHC.Cmm.CLabel
+import GHC.Cmm.InitFini
import GHC.Cmm
import GHC.CmmToAsm.Config
import GHC.Utils.Outputable as SDoc
@@ -220,8 +223,8 @@ pprGNUSectionHeader config t suffix =
| otherwise -> text ".rodata"
RelocatableReadOnlyData | OSMinGW32 <- platformOS platform
-- Concept does not exist on Windows,
- -- So map these to R/O data.
- -> text ".rdata$rel.ro"
+ -- So map these to data.
+ -> text ".data"
| otherwise -> text ".data.rel.ro"
UninitialisedData -> text ".bss"
InitArray
@@ -240,24 +243,79 @@ pprGNUSectionHeader config t suffix =
| OSMinGW32 <- platformOS platform
-> text ".rdata"
| otherwise -> text ".ipe"
- flags = case t of
- Text
- | OSMinGW32 <- platformOS platform, splitSections
- -> text ",\"xr\""
- | splitSections
- -> text ",\"ax\"," <> sectionType platform "progbits"
- CString
- | OSMinGW32 <- platformOS platform
- -> empty
- | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"
- IPE
- | OSMinGW32 <- platformOS platform
- -> empty
- | otherwise -> text ",\"a\"," <> sectionType platform "progbits"
- _ -> empty
+ flags
+ -- See
+ -- https://github.com/llvm/llvm-project/blob/llvmorg-21.1.8/lld/COFF/Chunks.cp…
+ -- and https://llvm.org/docs/Extensions.html#section-directive.
+ -- LLD COFF backend gc-sections only work on COMDAT sections so
+ -- we need to mark it as a COMDAT section. You can use clang64
+ -- toolchain to compile small examples with
+ -- `-ffunction-sections -fdata-sections -S` to see these section
+ -- headers in the wild. Also see Note [Split sections on COFF objects]
+ -- below.
+ | OSMinGW32 <- platformOS platform,
+ splitSections =
+ if
+ | Just _ <- isInitOrFiniSection t -> text ",\"dw\""
+ | otherwise ->
+ let coff_section_flags
+ | Text <- t = "xr"
+ | UninitialisedData <- t = "bw"
+ | ReadOnlySection <- sectionProtection t = "dr"
+ | otherwise = "dw"
+ in hcat
+ [ text ",\"",
+ text coff_section_flags,
+ text "\",one_only,",
+ pprCOFFComdatKey platform suffix
+ ]
+ | otherwise =
+ case t of
+ Text
+ | splitSections
+ -> text ",\"ax\"," <> sectionType platform "progbits"
+ CString
+ | OSMinGW32 <- platformOS platform
+ -> empty
+ | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"
+ IPE
+ | OSMinGW32 <- platformOS platform
+ -> empty
+ | otherwise -> text ",\"a\"," <> sectionType platform "progbits"
+ _ -> empty
{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-}
{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+-- | Note [Split sections on COFF objects]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- On Windows/COFF, LLD's gc-sections only works on COMDAT sections,
+-- so we mark split sections as COMDAT and need to provide a unique
+-- "key" symbol.
+--
+-- Important: We must not use a dot-prefixed local label (e.g.
+-- @.L...@) as the COMDAT key symbol, because LLVM's COFF assembler
+-- treats dot-prefixed COMDAT key symbols specially and forces them to
+-- have value 0 (the beginning of the section). That breaks
+-- @tablesNextToCode@, where the info label is intentionally placed
+-- after the info table data (at a non-zero offset).
+--
+-- Therefore we generate a non-dot-prefixed key symbol derived from
+-- the section suffix, and (see arch-specific 'pprSectionAlign') we
+-- emit a label definition for it at the beginning of the section.
+--
+-- ctor/dtor sections are specially treated; they must be emitted as
+-- regular data sections, otherwise LLD will drop them.
+--
+-- Note that we must not emit .equiv directives for COMDAT sections in
+-- COFF objects, they seriously confuse LLD and we end up with access
+-- violations at runtimes.
+pprCOFFComdatKey :: IsLine doc => Platform -> CLabel -> doc
+pprCOFFComdatKey platform suffix =
+ text "__ghc_coff_comdat_" <> pprAsmLabel platform suffix
+{-# SPECIALIZE pprCOFFComdatKey :: Platform -> CLabel -> SDoc #-}
+{-# SPECIALIZE pprCOFFComdatKey :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+
-- XCOFF doesn't support relocating label-differences, so we place all
-- RO sections into .text[PR] sections
pprXcoffSectionHeader :: IsLine doc => SectionType -> doc
=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -107,7 +107,7 @@ symKindFromCLabel lbl
-- | Calculate a data section's kind, see haddock docs of
-- 'DataSectionKind' for more explanation.
dataSectionKindFromCmmSection :: Section -> DataSectionKind
-dataSectionKindFromCmmSection s = case sectionProtection s of
+dataSectionKindFromCmmSection (Section t _) = case sectionProtection t of
ReadWriteSection -> SectionData
_ -> SectionROData
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Cmm hiding (topInfoTable)
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
+import GHC.Cmm.InitFini
import GHC.Cmm.DebugBlock (pprUnwindTable)
import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)
@@ -195,8 +196,12 @@ pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
+ -- See Note [Split sections on COFF objects]
+ , not $ platformOS platform == OSMinGW32 && ncgSplitSections config
= pprGloblDecl (ncgPlatform config) alias
$$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
+ where
+ platform = ncgPlatform config
pprDatas config (align, (CmmStaticsRaw lbl dats))
= vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)
@@ -526,9 +531,20 @@ pprAddr platform (AddrBaseIndex base index displacement)
-- | Print section header and appropriate alignment for that section.
pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
-pprSectionAlign config sec@(Section seg _) =
+pprSectionAlign config sec@(Section seg suffix) =
line (pprSectionHeader config sec) $$
+ coffSplitSectionComdatKey $$
pprAlignForSection (ncgPlatform config) seg
+ where
+ platform = ncgPlatform config
+ -- See Note [Split sections on COFF objects]
+ coffSplitSectionComdatKey
+ | OSMinGW32 <- platformOS platform
+ , ncgSplitSections config
+ , Nothing <- isInitOrFiniSection seg
+ = line (pprCOFFComdatKey platform suffix <> colon)
+ | otherwise
+ = empty
-- | Print appropriate alignment for the given section type.
pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -121,7 +121,7 @@ pprTop platform = \case
pprDataExterns platform lits $$
pprWordArray platform (isSecConstant section) lbl lits
where
- isSecConstant section = case sectionProtection section of
+ isSecConstant (Section t _) = case sectionProtection t of
ReadOnlySection -> True
WriteProtectedSection -> True
_ -> False
=====================================
compiler/GHC/CmmToLlvm/Data.hs
=====================================
@@ -75,7 +75,7 @@ genLlvmData (sect, statics)
IsFiniArray -> fsLit "llvm.global_dtors"
in genGlobalLabelArray var clbls
-genLlvmData (sec, CmmStaticsRaw lbl xs) = do
+genLlvmData (sec@(Section t _), CmmStaticsRaw lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
lmsec <- llvmSection sec
@@ -92,7 +92,7 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
then Just 2 else Just 1
Section Data _ -> Just $ platformWordSizeInBytes platform
_ -> Nothing
- const = if sectionProtection sec == ReadOnlySection
+ const = if sectionProtection t == ReadOnlySection
then Constant else Global
varDef = LMGlobalVar label tyAlias link lmsec align const
globDef = LMGlobal varDef struct
=====================================
docs/users_guide/exts/pragmas.rst
=====================================
@@ -58,10 +58,9 @@ prefixing it with "``-X``"; for example ``-XForeignFunctionInterface``.
A list of all supported language extensions can be obtained by invoking
``ghc --supported-extensions`` (see :ghc-flag:`--supported-extensions`).
+Alternatively see :ref:`table`.
-Any extension from the ``Extension`` type defined in
-:cabal-ref:`Language.Haskell.Extension.` may be used. GHC will report an error
-if any of the requested extensions are not supported.
+GHC will report an error if any of the requested extensions are not supported.
.. _options-pragma:
=====================================
docs/users_guide/exts/table.rst
=====================================
@@ -1,3 +1,5 @@
+.. _table:
+
Overview of all language extensions
-----------------------------------
=====================================
driver/utils/merge_sections.ld deleted
=====================================
@@ -1,26 +0,0 @@
-/* Linker script to undo -split-sections and merge all sections together when
- * linking relocatable object files for GHCi.
- * ld -r normally retains the individual sections, which is what you would want
- * if the intention is to eventually link into a binary with --gc-sections, but
- * it doesn't have a flag for directly doing what we want. */
-SECTIONS
-{
- .text : {
- *(.text*)
- }
- .rodata.cst16 : {
- *(.rodata.cst16*)
- }
- .rodata : {
- *(.rodata*)
- }
- .data.rel.ro : {
- *(.data.rel.ro*)
- }
- .data : {
- *(.data*)
- }
- .bss : {
- *(.bss*)
- }
-}
=====================================
driver/utils/merge_sections_pe.ld deleted
=====================================
@@ -1,26 +0,0 @@
-/* Linker script to undo -split-sections and merge all sections together when
- * linking relocatable object files for GHCi.
- * ld -r normally retains the individual sections, which is what you would want
- * if the intention is to eventually link into a binary with --gc-sections, but
- * it doesn't have a flag for directly doing what we want. */
-SECTIONS
-{
- .text : {
- *(.text$*)
- }
- .rdata : {
- *(.rdata$*)
- }
- .data : {
- *(.data$*)
- }
- .pdata : {
- *(.pdata$*)
- }
- .xdata : {
- *(.xdata$*)
- }
- .bss : {
- *(.bss$*)
- }
-}
=====================================
hadrian/hadrian.cabal
=====================================
@@ -115,7 +115,6 @@ executable hadrian
, Settings.Builders.Ar
, Settings.Builders.Ld
, Settings.Builders.Make
- , Settings.Builders.MergeObjects
, Settings.Builders.SplitSections
, Settings.Builders.RunTest
, Settings.Builders.Win32Tarballs
=====================================
hadrian/src/Builder.hs
=====================================
@@ -178,7 +178,6 @@ data Builder = Alex
| Ld Stage --- ^ linker
| Make FilePath
| Makeinfo
- | MergeObjects Stage -- ^ linker to be used to merge object files.
| Nm
| Objdump
| Python
@@ -453,15 +452,6 @@ systemBuilderPath builder = case builder of
HsCpp -> fromTargetTC "hs-cpp" (Toolchain.hsCppProgram . tgtHsCPreprocessor)
JsCpp -> fromTargetTC "js-cpp" (maybeProg Toolchain.jsCppProgram . tgtJsCPreprocessor)
Ld _ -> fromTargetTC "ld" (Toolchain.ccLinkProgram . tgtCCompilerLink)
- -- MergeObjects Stage0 is a special case in case of
- -- cross-compiling. We're building stage1, e.g. code which will be
- -- executed on the host and hence we need to use host's merge
- -- objects tool and not the target merge object tool.
- -- Note, merge object tool is usually platform linker with some
- -- parameters. E.g. building a cross-compiler on and for x86_64
- -- which will target ppc64 means that MergeObjects Stage0 will use
- -- x86_64 linker and MergeObject _ will use ppc64 linker.
- MergeObjects st -> fromStageTC st "merge-objects" (maybeProg Toolchain.mergeObjsProgram . tgtMergeObjs)
Make _ -> fromKey "make"
Makeinfo -> fromKey "makeinfo"
Nm -> fromTargetTC "nm" (Toolchain.nmProgram . tgtNm)
=====================================
hadrian/src/Context.hs
=====================================
@@ -8,7 +8,7 @@ module Context (
-- * Paths
contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir,
pkgHaddockFile, pkgRegisteredLibraryFile, pkgRegisteredLibraryFileName,
- pkgLibraryFile, pkgGhciLibraryFile,
+ pkgLibraryFile,
pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir,
distDynDir,
haddockStatsFilesDir, ensureConfigured, autogenPath, rtsContext, rtsBuildPath, libffiBuildPath
@@ -155,13 +155,6 @@ pkgLibraryFile context@Context {..} = do
extension <- libsuf stage way
pkgFile context "libHS" extension
--- | Path to the GHCi library file of a given 'Context', e.g.:
--- @_build/stage1/libraries/array/build/HSarray-0.5.1.0.o@.
-pkgGhciLibraryFile :: Context -> Action FilePath
-pkgGhciLibraryFile context@Context {..} = do
- let extension = "" <.> osuf way
- pkgFile context "HS" extension
-
-- | Path to the configuration file of a given 'Context'.
pkgConfFile :: Context -> Action FilePath
pkgConfFile Context {..} = do
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -334,7 +334,6 @@ resolveContextData context@Context {..} = do
, depIncludeDirs = forDeps Installed.includeDirs
, depCcOpts = forDeps Installed.ccOptions
, depLdOpts = forDeps Installed.ldOptions
- , buildGhciLib = C.withGHCiLib lbi'
, frameworks = map C.getSymbolicPath (C.frameworks buildInfo)
, packageDescription = pd'
, contextLibdir = libdir install_dirs
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Type.hs
=====================================
@@ -67,7 +67,6 @@ data ContextData = ContextData
, depIncludeDirs :: [String]
, depCcOpts :: [String]
, depLdOpts :: [String]
- , buildGhciLib :: Bool
, frameworks :: [String]
, packageDescription :: PackageDescription
=====================================
hadrian/src/Hadrian/Haskell/Hash.hs
=====================================
@@ -82,7 +82,6 @@ data PackageHashConfigInputs = PackageHashConfigInputs {
pkgHashVanillaLib :: Bool,
pkgHashSharedLib :: Bool,
pkgHashDynExe :: Bool,
- pkgHashGHCiLib :: Bool,
pkgHashProfLib :: Bool,
pkgHashProfExe :: Bool,
pkgHashSplitObjs :: Bool,
@@ -139,7 +138,6 @@ pkgHashOracle = void $ addOracleCache $ \(PkgHashKey (stag, pkg)) -> do
pkgHashVanillaLib = vanilla `Set.member` libWays
pkgHashSharedLib = dynamic `Set.member` libWays
pkgHashDynExe = dyn_ghc
- pkgHashGHCiLib = False
pkgHashProfLib = profiling `Set.member` libWays
pkgHashProfExe = pkg == ghc && ghcProfiled flav stag
pkgHashSplitObjs = False -- Deprecated
@@ -239,7 +237,6 @@ renderPackageHashInputs PackageHashInputs{
, opt "vanilla-lib" True show pkgHashVanillaLib
, opt "shared-lib" False show pkgHashSharedLib
, opt "dynamic-exe" False show pkgHashDynExe
- , opt "ghci-lib" False show pkgHashGHCiLib
, opt "prof-lib" False show pkgHashProfLib
, opt "prof-exe" False show pkgHashProfExe
, opt "split-objs" False show pkgHashSplitObjs
=====================================
hadrian/src/Oracles/Flag.hs
=====================================
@@ -3,7 +3,6 @@
module Oracles.Flag (
Flag (..), flag, getFlag,
platformSupportsSharedLibs,
- platformSupportsGhciObjects,
targetRTSLinkerOnlySupportsSharedLibs,
targetSupportsThreadedRts,
targetSupportsSMP,
@@ -71,15 +70,6 @@ flag f = do
getFlag :: Flag -> Expr c b Bool
getFlag = expr . flag
--- | Does the platform support object merging (and therefore we can build GHCi objects
--- when appropriate).
-platformSupportsGhciObjects :: Action Bool
--- FIXME: The name of the function is not entirely clear about which platform, it would be better named targetSupportsGhciObjects
-platformSupportsGhciObjects = do
- has_merge_objs <- isJust <$> queryTargetTarget tgtMergeObjs
- only_shared_libs <- targetRTSLinkerOnlySupportsSharedLibs
- pure $ has_merge_objs && not only_shared_libs
-
targetRTSLinkerOnlySupportsSharedLibs :: Action Bool
targetRTSLinkerOnlySupportsSharedLibs = queryTargetTarget Toolchain.tgtRTSLinkerOnlySupportsSharedLibs
=====================================
hadrian/src/Rules.hs
=====================================
@@ -71,16 +71,9 @@ topLevelTargets = action $ do
name stage pkg | isLibrary pkg = return (pkgName pkg)
| otherwise = programName (vanillaContext stage pkg)
--- TODO: Get rid of the @includeGhciLib@ hack.
-- | Return the list of targets associated with a given 'Stage' and 'Package'.
--- By setting the Boolean parameter to False it is possible to exclude the GHCi
--- library from the targets, and avoid configuring the package to determine
--- whether GHCi library needs to be built for it. We typically want to set
--- this parameter to True, however it is important to set it to False when
--- computing 'topLevelTargets', as otherwise the whole build gets sequentialised
--- because packages are configured in the order respecting their dependencies.
-packageTargets :: Bool -> Stage -> Package -> Action [FilePath]
-packageTargets includeGhciLib stage pkg = do
+packageTargets :: Stage -> Package -> Action [FilePath]
+packageTargets stage pkg = do
let context = vanillaContext stage pkg
activePackages <- stagePackages stage
if pkg `notElem` activePackages
@@ -90,7 +83,7 @@ packageTargets includeGhciLib stage pkg = do
let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
ways <- interpretInContext context pkgWays
libs <- mapM (\w -> pkgLibraryFile (Context stage pkg w (error "unused"))) (Set.toList ways)
- more <- Rules.Library.libraryTargets includeGhciLib context
+ more <- Rules.Library.libraryTargets context
setupConfig <- pkgSetupConfigFile context
return $ [setupConfig] ++ libs ++ more
else do -- The only target of a program package is the executable.
=====================================
hadrian/src/Rules/Library.hs
=====================================
@@ -35,8 +35,6 @@ libraryRules = do
root -/- "stage*/lib/**/libHS*-*.so" %> registerDynamicLib root "so"
root -/- "stage*/lib/**/libHS*-*.dll" %> registerDynamicLib root "dll"
root -/- "stage*/lib/**/*.a" %> registerStaticLib root
- root -/- "**/HS*-*.o" %> buildGhciLibO root
- root -/- "**/HS*-*.p_o" %> buildGhciLibO root
-- * 'Action's for building libraries
@@ -100,20 +98,6 @@ buildDynamicLib root suffix dynlibpath = do
(quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
dynlibpath synopsis
--- | Build a "GHCi library" ('LibGhci') under the given build root, with the
--- complete path of the file to build is given as the second argument.
--- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
-buildGhciLibO :: FilePath -> FilePath -> Action ()
-buildGhciLibO root ghcilibPath = do
- l@(BuildPath _ stage _ (LibGhci _ _ _ _))
- <- parsePath (parseBuildLibGhci root)
- "<.o ghci lib (build) path parser>"
- ghcilibPath
- let context = libGhciContext l
- objs <- allObjects context
- need objs
- build $ target context (MergeObjects stage) objs [ghcilibPath]
-
{-
Note [Stamp Files]
@@ -145,7 +129,7 @@ buildPackage root fp = do
srcs <- hsSources ctx
gens <- interpretInContext ctx generatedDependencies
- lib_targets <- libraryTargets True ctx
+ lib_targets <- libraryTargets ctx
need (srcs ++ gens ++ lib_targets)
@@ -166,10 +150,6 @@ buildPackage root fp = do
-- * Helpers
--- | Return all Haskell and non-Haskell object files for the given 'Context'.
-allObjects :: Context -> Action [FilePath]
-allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
-
-- | Return all the non-Haskell object files for the given library context
-- (object files built from C, C-- and sometimes other things).
nonHsObjects :: Context -> Action [FilePath]
@@ -228,7 +208,7 @@ libraryObjects context = do
-- | Coarse-grain 'need': make sure all given libraries are fully built.
needLibrary :: [Context] -> Action ()
-needLibrary cs = need =<< concatMapM (libraryTargets True) cs
+needLibrary cs = need =<< concatMapM libraryTargets cs
-- * Library paths types and parsers
@@ -241,9 +221,6 @@ data DynLibExt = So | Dylib deriving (Eq, Show)
-- | > libHS<pkg name>-<pkg version>-<pkg hash>[_<way suffix>]-ghc<ghc version>.<so|dylib>
data LibDyn = LibDyn String [Integer] String Way DynLibExt deriving (Eq, Show)
--- | > HS<pkg name>-<pkg version>-<pkg hash>[_<way suffix>].o
-data LibGhci = LibGhci String [Integer] String Way deriving (Eq, Show)
-
-- | Get the 'Context' corresponding to the build path for a given static library.
libAContext :: BuildPath LibA -> Context
libAContext (BuildPath _ stage pkgpath (LibA pkgname _ _ way)) =
@@ -251,13 +228,6 @@ libAContext (BuildPath _ stage pkgpath (LibA pkgname _ _ way)) =
where
pkg = library pkgname pkgpath
--- | Get the 'Context' corresponding to the build path for a given GHCi library.
-libGhciContext :: BuildPath LibGhci -> Context
-libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ _ way)) =
- Context stage pkg way Final
- where
- pkg = library pkgname pkgpath
-
-- | Get the 'Context' corresponding to the build path for a given dynamic library.
libDynContext :: BuildPath LibDyn -> Context
libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ _ way _)) =
@@ -274,9 +244,8 @@ stampContext (BuildPath _ stage _ (PkgStamp pkgname _ _ way)) =
data PkgStamp = PkgStamp String [Integer] String Way deriving (Eq, Show)
-
--- | Parse a path to a ghci library to be built, making sure the path starts
--- with the given build root.
+-- | Parse a path to a package stamp file, making sure the path starts with the
+-- given build root.
parseStampPath :: FilePath -> Parsec.Parsec String () (BuildPath PkgStamp)
parseStampPath root = parseBuildPath root parseStamp
@@ -297,12 +266,6 @@ parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
parseBuildLibA root = parseBuildPath root parseLibAFilename
Parsec.<?> "build path for a static library"
--- | Parse a path to a ghci library to be built, making sure the path starts
--- with the given build root.
-parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
-parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
- Parsec.<?> "build path for a ghci library"
-
-- | Parse a path to a dynamic library to be built, making sure the path starts
-- with the given build root.
parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
@@ -324,16 +287,6 @@ parseLibAFilename = do
_ <- Parsec.string ".a"
return (LibA pkgname pkgver pkghash way)
--- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
-parseLibGhciFilename :: Parsec.Parsec String () LibGhci
-parseLibGhciFilename = do
- _ <- Parsec.string "HS"
- (pkgname, pkgver, pkghash) <- parsePkgId
- _ <- Parsec.string "."
- way <- parseWayPrefix vanilla
- _ <- Parsec.string "o"
- return (LibGhci pkgname pkgver pkghash way)
-
-- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
parseLibDynFilename ext = do
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -6,20 +6,17 @@ module Rules.Register (
import Base
import Context
-import Expression ( getContextData )
import Flavour
import Oracles.Setting
import Hadrian.BuildPath
import Hadrian.Expression
import Hadrian.Haskell.Cabal
-import Oracles.Flag (platformSupportsGhciObjects)
import Packages
import Rules.Rts
import Settings
import Target
import Utilities
-import Hadrian.Haskell.Cabal.Type
import qualified Text.Parsec as Parsec
import qualified Data.Set as Set
import qualified Data.Char as Char
@@ -298,17 +295,9 @@ extraTargets context
-- | Given a library 'Package' this action computes all of its targets. Needing
-- all the targets should build the library such that it is ready to be
-- registered into the package database.
--- See 'Rules.packageTargets' for the explanation of the @includeGhciLib@
--- parameter.
-libraryTargets :: Bool -> Context -> Action [FilePath]
-libraryTargets includeGhciLib context@Context {..} = do
+libraryTargets :: Context -> Action [FilePath]
+libraryTargets context = do
libFile <- pkgLibraryFile context
- ghciLib <- pkgGhciLibraryFile context
- ghciObjsSupported <- platformSupportsGhciObjects
- ghci <- if ghciObjsSupported && includeGhciLib && not (wayUnit Dynamic way)
- then interpretInContext context $ getContextData buildGhciLib
- else return False
extra <- extraTargets context
return $ [ libFile ]
- ++ [ ghciLib | ghci ]
++ extra
=====================================
hadrian/src/Settings/Builders/Cabal.hs
=====================================
@@ -5,13 +5,12 @@ import Hadrian.Haskell.Cabal
import Builder
import Context
-import Flavour
import Packages
import Settings.Builders.Common
import qualified Settings.Builders.Common as S
import Control.Exception (assert)
import qualified Data.Set as Set
-import Settings.Program (programContext, ghcWithInterpreter)
+import Settings.Program (programContext)
import GHC.Toolchain (ccLinkProgram, tgtCCompilerLink)
import GHC.Toolchain.Program (prgFlags)
@@ -128,7 +127,6 @@ commonCabalArgs stage = do
]
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
--- TODO: Need compiler_stage1_CONFIGURE_OPTS += --disable-library-for-ghci?
-- TODO: should `elem` be `wayUnit`?
-- This approach still doesn't work. Previously libraries were build only in the
-- Default flavours and not using context.
@@ -136,11 +134,6 @@ libraryArgs :: Args
libraryArgs = do
flavourWays <- getLibraryWays
contextWay <- getWay
- package <- getPackage
- stage <- getStage
- withGhci <- expr $ ghcWithInterpreter stage
- dynPrograms <- expr (flavour >>= dynamicGhcPrograms)
- ghciObjsSupported <- expr platformSupportsGhciObjects
let ways = Set.insert contextWay flavourWays
hasVanilla = vanilla `elem` ways
hasProfiling = any (wayUnit Profiling) ways
@@ -155,11 +148,7 @@ libraryArgs = do
, if hasProfilingShared
then "--enable-profiling-shared"
else "--disable-profiling-shared"
- , if ghciObjsSupported &&
- (hasVanilla || hasProfiling) &&
- package /= rts && withGhci && not dynPrograms
- then "--enable-library-for-ghci"
- else "--disable-library-for-ghci"
+ , "--disable-library-for-ghci"
, if hasDynamic
then "--enable-shared"
else "--disable-shared" ]
=====================================
hadrian/src/Settings/Builders/MergeObjects.hs deleted
=====================================
@@ -1,11 +0,0 @@
-module Settings.Builders.MergeObjects (mergeObjectsBuilderArgs) where
-
-import Settings.Builders.Common
-import GHC.Toolchain
-import GHC.Toolchain.Program
-
-mergeObjectsBuilderArgs :: Args
-mergeObjectsBuilderArgs = builder MergeObjects ? mconcat
- [ maybe [] (prgFlags . mergeObjsProgram) . tgtMergeObjs <$> getStagedTarget
- , arg "-o", arg =<< getOutput
- , getInputs ]
=====================================
hadrian/src/Settings/Builders/SplitSections.hs
=====================================
@@ -32,8 +32,5 @@ splitSectionsArgs = do
, builder (Ghc CompileCWithGhc) ? arg "-fsplit-sections"
, builder (Ghc CompileCppWithGhc) ? arg "-fsplit-sections"
, builder (Cc CompileC) ? arg "-ffunction-sections" <> arg "-fdata-sections"
- , builder MergeObjects ? ifM (expr isWinTarget)
- (pure ["-T", "driver/utils/merge_sections_pe.ld"])
- (pure ["-T", "driver/utils/merge_sections.ld"])
]
) else mempty
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -40,7 +40,6 @@ import Settings.Builders.HsCpp
import Settings.Builders.Ar
import Settings.Builders.Ld
import Settings.Builders.Make
-import Settings.Builders.MergeObjects
import Settings.Builders.SplitSections
import Settings.Builders.RunTest
import Settings.Builders.Xelatex
@@ -328,7 +327,6 @@ defaultBuilderArgs = mconcat
, ldBuilderArgs
, arBuilderArgs
, makeBuilderArgs
- , mergeObjectsBuilderArgs
, runTestBuilderArgs
, validateBuilderArgs
, xelatexBuilderArgs
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -75,8 +75,7 @@ packageArgs = do
pure ["-O0"] ]
, builder (Cabal Setup) ? mconcat
- [ arg "--disable-library-for-ghci"
- , anyTargetOs [OSOpenBSD] ? arg "--ld-options=-E"
+ [ anyTargetOs [OSOpenBSD] ? arg "--ld-options=-E"
, compilerStageOption ghcProfiled ? arg "--ghc-pkg-option=--force"
, cabalExtraDirs libzstdIncludeDir libzstdLibraryDir
]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/043299efc7e99947b8eb746b9fa4d2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/043299efc7e99947b8eb746b9fa4d2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: hadrian: drops unused PE linker script for windows
by Marge Bot (＠marge-bot) 06 Jan '26
by Marge Bot (＠marge-bot) 06 Jan '26
06 Jan '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a8a94aad by Cheng Shao at 2026-01-05T16:24:04-05:00
hadrian: drops unused PE linker script for windows
This patch drops unused PE linker script for windows in the
`MergeObjects` builder of hadrian. The linker script is used for
merging object files into a single `HS*.o` object file and undoing the
effect of split sections, when building the "ghci library" object
file. However, we don't build the ghci library on windows, and this
code path is actually unreachable.
- - - - -
53038ea9 by Cheng Shao at 2026-01-05T16:24:04-05:00
hadrian: drop unused logic for building ghci libraries
This patch drops the unused logic for building ghci libraries in
hadrian:
- The term "ghci library" refers to an optional object file per
library `HS*.o`, which is merged from multiple object files in that
library using the `MergeObjects` builder in hadrian.
- The original rationale of having a ghci library object, in addition
to normal archives, was to speedup ghci loading, since the combined
object is linked with a linker script to undo the effects of
`-fsplit-sections` to reduce section count and make it easier for
the RTS linker to handle.
- However, most GHC builds enable `dynamicGhcPrograms` by default, in
such cases the ghci library would already not be built.
- `dynamicGhcPrograms` is disabled on Windows, but still we don't
build the ghci library due to lack of functioning merge objects
command.
- The only case that we actually build ghci library objects, are
alpine fully static bindists. However, for other reasons, split
sections is already disabled for fully static builds anyway!
- There will not be any regression if the ghci library objects are
absent from a GHC global libdir when `dynamicGhcPrograms` is
disabled. The RTS linker can already load the archives without any
issue.
Hence the removal. We now forcibly disable ghci libraries for all
Cabal components, and rip out all logic related to `MergeObjects` and
ghci libraries in hadrian. This also nicely cleans up some old todos
and fixmes that are no longer relevant.
Note that MergeObjects in hadrian is not the same thing as merge
objects in the GHC driver. The latter is not affected by this patch.
-------------------------
Metric Decrease:
libdir
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
8f209336 by Simon Jakobi at 2026-01-05T16:24:48-05:00
User's guide: Fix link to language extensions
Instead of linking to haddocks, it seemed more useful to link
to the extension overview in the user's guide.
Closes #26614.
- - - - -
4fe52f81 by Simon Peyton Jones at 2026-01-06T04:21:49-05:00
Improved fundeps for closed type families
The big payload of this commit is to execute the plan suggested
in #23162, by improving the way that we generate functional
dependencies for closed type families.
It is all described in Note [Exploiting closed type families]
Most of the changes are in GHC.Tc.Solver.FunDeps
Other small changes
* GHC.Tc.Solver.bumpReductionDepth. This function brings together the code that
* Bumps the depth
* Checks for overflow
Previously the two were separated, sometimes quite widely.
* GHC.Core.Unify.niFixSubst: minor improvement, removing an unnecessary
itraetion in the base case.
* GHC.Core.Unify: no need to pass an InScopeSet to
tcUnifyTysForInjectivity. It can calculate one for itself; and it is
never inspected anyway so it's free to do so.
* GHC.Tc.Errors.Ppr: slight impovement to the error message for
reduction-stack overflow, when a constraint (rather than a type) is
involved.
* GHC.Tc.Solver.Monad.wrapUnifier: small change to the API
- - - - -
f2c3b984 by Simon Peyton Jones at 2026-01-06T04:21:49-05:00
Add missing (KK4) to kick-out criteria
There was a missing case in kick-out that meant we could fail
to solve an eminently-solvable constraint.
See the new notes about (KK4)
- - - - -
54d04ecd by Simon Peyton Jones at 2026-01-06T04:21:49-05:00
Some small refactorings of error reporting in the typechecker
This is just a tidy-up commit.
* Add ei_insoluble to ErrorItem, to cache insolubility.
Small tidy-up.
* Remove `is_ip` and `mkIPErr` from GHC.Tc.Errors; instead enhance mkDictErr
to handle implicit parameters. Small refactor.
- - - - -
570ea3b6 by Simon Peyton Jones at 2026-01-06T04:21:49-05:00
Improve recording of insolubility for fundeps
This commit addresses #22652, by recording when the fundeps for
a constraint are definitely insoluble. That in turn improves the
perspicacity of the pattern-match overlap checker.
See Note [Insoluble fundeps]
- - - - -
5a83f53f by Simon Peyton Jones at 2026-01-06T04:21:49-05:00
Fix a buglet in niFixSubst
The MR of which this is part failed an assertion check extendTvSubst
because we extended the TvSubst with a CoVar. Boo.
This tiny patch fixes it, and adds the regression test from #13882
that showed it up.
- - - - -
28a7a94e by konsumlamm at 2026-01-06T04:22:01-05:00
Fix changelog formatting
- - - - -
89 changed files:
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/CtLoc.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/TyThing.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/exts/pragmas.rst
- docs/users_guide/exts/table.rst
- − driver/utils/merge_sections.ld
- − driver/utils/merge_sections_pe.ld
- hadrian/hadrian.cabal
- hadrian/src/Builder.hs
- hadrian/src/Context.hs
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Hadrian/Haskell/Cabal/Type.hs
- hadrian/src/Hadrian/Haskell/Hash.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Settings/Builders/Cabal.hs
- − hadrian/src/Settings/Builders/MergeObjects.hs
- hadrian/src/Settings/Builders/SplitSections.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/changelog.md
- linters/lint-codes/LintCodes/Static.hs
- testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs
- testsuite/tests/indexed-types/should_fail/T12522a.hs
- testsuite/tests/indexed-types/should_fail/T26176.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
- testsuite/tests/parser/should_fail/T20654a.stderr
- testsuite/tests/pmcheck/should_compile/T15753c.hs
- + testsuite/tests/pmcheck/should_compile/T15753c.stderr
- testsuite/tests/pmcheck/should_compile/T15753d.hs
- + testsuite/tests/pmcheck/should_compile/T15753d.stderr
- + testsuite/tests/pmcheck/should_compile/T22652.hs
- + testsuite/tests/pmcheck/should_compile/T22652a.hs
- testsuite/tests/pmcheck/should_compile/all.T
- + testsuite/tests/polykinds/T13882.hs
- testsuite/tests/polykinds/all.T
- testsuite/tests/quantified-constraints/T15316A.stderr
- testsuite/tests/quantified-constraints/T17267.stderr
- testsuite/tests/quantified-constraints/T17267a.stderr
- testsuite/tests/quantified-constraints/T17267b.stderr
- testsuite/tests/quantified-constraints/T17267c.stderr
- testsuite/tests/quantified-constraints/T17267e.stderr
- testsuite/tests/quantified-constraints/T17458.stderr
- testsuite/tests/typecheck/should_compile/T16188.hs
- testsuite/tests/typecheck/should_fail/ContextStack1.stderr
- testsuite/tests/typecheck/should_fail/FD3.stderr
- testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr
- testsuite/tests/typecheck/should_fail/FunDepOrigin1b.stderr
- testsuite/tests/typecheck/should_fail/T13506.stderr
- testsuite/tests/typecheck/should_fail/T15767.stderr
- testsuite/tests/typecheck/should_fail/T19415.stderr
- testsuite/tests/typecheck/should_fail/T19415b.stderr
- testsuite/tests/typecheck/should_fail/T22924b.stderr
- + testsuite/tests/typecheck/should_fail/T23162b.hs
- + testsuite/tests/typecheck/should_fail/T23162b.stderr
- + testsuite/tests/typecheck/should_fail/T23162c.hs
- + testsuite/tests/typecheck/should_fail/T23162d.hs
- testsuite/tests/typecheck/should_fail/T25325.stderr
- testsuite/tests/typecheck/should_fail/T5236.stderr
- testsuite/tests/typecheck/should_fail/T5246.stderr
- testsuite/tests/typecheck/should_fail/T5978.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail143.stderr
- utils/haddock/haddock-api/src/Haddock/Convert.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff86c8e71e921254a7f31604ae4fed…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff86c8e71e921254a7f31604ae4fed…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Cheng Shao pushed new branch wip/hi-atomic at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/hi-atomic
You're receiving this email because of your account on gitlab.haskell.org.
1
0
06 Jan '26
Cheng Shao pushed new branch wip/cleanup-cygwin at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/cleanup-cygwin
You're receiving this email because of your account on gitlab.haskell.org.
1
0