05 Dec '25
Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC
Commits:
f32d29b6 by Simon Peyton Jones at 2025-12-05T00:37:45+00:00
Add comments [skip ci]
- - - - -
1 changed file:
- compiler/GHC/Tc/Solver/FunDeps.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -522,9 +522,6 @@ mkTopFamEqFDs fam_tc work_args work_rhs
| Just ax <- isClosedFamilyTyCon_maybe fam_tc
= -- Closed type families
- -- Look at the top-level axioms; we effectively infer injectivity,
- -- so we don't need tyConInjectivtyInfo. This works fine for closed
- -- type families without injectivity info
mkTopClosedFamEqFDs ax work_args work_rhs
| otherwise
@@ -551,6 +548,10 @@ tryFDEqns fam_tc work_args work_item@(EqCt { eq_ev = ev, eq_rhs= rhs }) mk_fd_eq
-- User-defined type families
-----------------------------------------
mkTopClosedFamEqFDs :: CoAxiom Branched -> [TcType] -> Xi -> TcS [FunDepEqns]
+-- Look at the top-level axioms; we effectively infer injectivity,
+-- so we don't need tyConInjectivtyInfo. This works fine for closed
+-- type families without injectivity info
+-- See Note [Exploiting closed type families]
mkTopClosedFamEqFDs ax work_args work_rhs
= do { let branches = fromBranches (coAxiomBranches ax)
; traceTcS "mkTopClosed" (ppr branches $$ ppr work_args $$ ppr work_rhs)
@@ -847,6 +848,184 @@ For /built-in/ type families, it's pretty similar, except that
equation would indeed be the one to fire. So we call `apartnessCheck`
on the branch to ensure this, in `mkTopUserFamEqFDs`.
+Definition [Relevance]
+~~~~~~~~~~~~~~~~~~~~~~
+We say that a closed-type-family equation `F lhs = rhs` is
+ /relevant/ for a Wanted [W] F wlhs ~ wrhs
+iff
+ (R1) (lhs,rhs) pre-unifies with (wlhs,wrhs) yielding substitution S.
+ See (RW1),(RW2), (RW3)
+
+ (R2) There is no earlier equation that matches S(lhs). See (RW4) below.
+
+(RW1) Pre-unification treats type-family applications as binding to anything,
+ rather like type variables. If two types don't even pre-unify, we say that they
+ are /apart/. It is done by `tcUnifyTysForInjectivity`.
+
+(RW2) lhs and wlhs are of course each a list of types. We don't really form a
+ tuple (lhs,rhs); we just pre-unify the list (rhs_ty : lhs_tys).
+
+(RW3) Why "pre-unifies with" rather than "unifies with"? Answer: see Section 5.2
+ in "Injective Type Families for Haskell". A concrete example is test T12522a:
+
+ newtype I a = I a
+
+ type family Curry (as :: [Type]) b = f | f -> as b where
+ Curry '[] b = I b
+ Curry (a:as) b = a -> Curry as b
+
+ [W] Curry alpha beta ~ (gamma -> String -> I String)
+
+
+ Clearly the RHS is apart from the first equation and we want to fire injectivity
+ on the second equation.
+
+(RW4) Why "no earlier equation matches" in conditoin (R2)? Consider the family
+
+ type family Bak a = r where
+ Bak Int = Char -- B1
+ Bak Char = Int -- B2
+ Bak a = a -- B3
+
+ and [W] Bak alpha ~ Char. In fact, only (B2) is relevant for this Wanted.
+ You might think that (B3) could be instantiated to Bak Char ~ Char; but
+ actually that instantiation will never fire because (B2) Bak Char ~ Int would
+ fire first. So the only way to return a Char is if the argment is Int; so we
+ can emit [W] alpha ~ Int. Hence (B3) is not relevant; only (B2) is relevant.
+
+ That is the reason for condition (R2) in the definition of Relevance above.
+ A watertight proof that this is the Right Thing is not very easy. See more
+ discussion in #23162.
+
+Note [Exploiting closed type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ type family F a b where
+ F Int Bool = Bool -- (F1)
+ F Int Char = Char -- (F2)
+ F Bool a = Char -- (F3)
+
+ [W] F Int alpha ~ Char
+
+The /only/ way to solve this Wanted is using (F2), so we can safely unify
+alpha:=Char without risking losing any solutions. That is what
+`mkTopClosedFamEqFDs` does. Ticket #23162 has lots of background detail
+
+More precisely, here is the Closed Family Fundep Algorithm (CFFA)
+
+ IF * F a is a closed type family.
+ * We are trying to solve [W] F wlhs ~ wrhs.
+ * There are no "relevant" Givens [G] F lhs ~ rhs. See (CF1) below.
+ * F has exactly one equation, F lhs = rhs that is "relevant" for that Wanted
+ THEN
+ we can emit and solve the fundep equalities:
+ [W] wlhs1 ~ lhs1
+ ...
+ [W] wlhsn ~ lhsn
+ [W] wrhs ~ rhs See (CF2) below.
+ with fresh unification vars in lhs and rhs for the quantified variables of the
+ equation.
+
+See Definition [Relevance] for what "relevant" means.
+We need to take care about non-termination; see (CF3).
+
+Key point: equations that are not relevant do not need to be considered for fundeps at all.
+
+(CF1) Why "no relevant Givens"? Consider test `CEqCanOccursCheck`:
+
+ type family F a where
+ F Bool = Bool
+ type family G a b where
+ G a a = a
+
+ foo :: (F a ~ a, F a ~ b) => G a b -> ()
+
+ In the ambiguity check for foo we get
+ [G] F a ~ a
+ [G] F a ~ b
+ [W] F alpha ~ alpha
+ [W] F alpha ~ beta
+ [W] G a b ~ G alpha beta
+
+ Now use algoritm (CFFA) on [W] F alpha ~ alpha. There is only one
+ equation for F, and it is relevant, so we gaily emit the fundep equality
+ [W] alpha ~ Bool, and we are immediately dead. We end up with
+ • Could not deduce ‘b ~ Bool’
+ from the context: (F a ~ a, F a ~ b)
+
+ It is true that the only way a caller can satisfy F a ~ a is by instantiating
+ a to Bool; but we don't have /evidence/ for that which we can use to satisfy
+ b ~ Bool.
+
+ The trouble is that (CFFA) relies on knowing /all/ the equations for F;
+ but in this case we have some Given constraints that locally extend F.
+
+ This relates closely to
+ Note [Do local fundeps before top-level instances] and
+ Note [Do fundeps last] (which are saying much the same thing)
+
+ These Notes are extremely delicate. Suppose a local Given doesn't give rise
+ to a fundep equation and we move on to the top-level fundeps; but then after
+ some other constraints are solved the local Given would fire. Indeed this is
+ exactly what happens above!
+
+ Solution: Only run (CFFA) if there are no relevant Givens. This is much more
+ robust than "only run (CFFA) if attempting local fundeps gives rise to
+ equations" because if a Given is irrelevant is is forever irrelevant. It's a
+ bit like `noMatchableGivenDicts` and `mightEqualLater` for dictionaries.
+ Indeed we should probably apply a similar check when doing fundeps on
+ dictionaries.
+
+(CF2) Fundeps from RHS as well as LHS. Consider this from test T6018:
+
+ type family Bak a = r where
+ Bak Int = Char
+ Bak Char = Int
+ Bak a = a
+
+ and [W] Bak alpha ~ (). Only the last equation is relevant, but we clearly
+ don't want to just produce a new fundep Wanted for the LHS: beta ~ alpha,
+ where beta is freshly instantiated from a. We must /also/ produce an equality
+ [W] beta ~ () from the RHS. Hence the [W] wrhs ~ rhs in (CFFA).
+
+(CF3) Algorithm (CFFA) can diverge, just as ordinary fundeps can, as discussed
+ extensively in the paper "Understanding functional dependencies via constraint
+ handling rules". Example (test T16512a):
+
+ type family LV as b where
+ LV (a : as) b = a -> LV as b
+
+ [W] LV as bsk ~ LV as (ask->bsk)
+
+ Here `as` is a unification variable, while `ask` and `bsk` are skolems.
+ There is one relevant equation, because there is only one equation in the
+ family! Hence algorithm (CFFA) generates new equalities
+ x:asx ~ as
+ bx ~ bsk
+ (ax -> LV asx bx) ~ LV as (ask->bsk)
+
+ where ax, asx and bx are fresh unification variables. We can solve:
+ as := ax:asx
+ bx := bsk
+
+ Leaving us with
+ (ax -> LV asx bsk) ~ LV (ax:asx) (ask->bsk)
+ -->{reduce RHS with the equation for LV}
+ (ax -> LV asx bsk) ~ (ax -> LV asx (ask->bsk))
+ -->{decompose ->)
+ LV asx bsk ~ LV asx (ask->bsk)
+
+ And now we are back where we started -- loop.
+
+ We solve this by bumping the `ctLocDepth` in `solveFunDeps`, and imposing
+ a depth bound. See the call to `bumpReductionDepth`.
+
+(CF4) If one of the fundeps generated by interacting with the local equalities is
+ definitely insoluble (e.g. Int~Bool) then there is no point in continuing to
+ look at the global type-family definitions. That can happen. It came up when
+ I was looking at non-termination for closed type families, but it's a small
+ improvement in general.
+
Note [Cache-caused loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
@@ -903,6 +1082,7 @@ solveFunDeps work_ev fd_eqns
| otherwise
= do { traceTcS "bumping" (ppr work_ev)
; loc' <- bumpReductionDepth (ctEvLoc work_ev) (ctEvPred work_ev)
+ -- See (CF3) in Note [Exploiting closed type families]
; (unifs, residual)
<- reportFineGrainUnifications $
@@ -923,6 +1103,7 @@ solveFunDeps work_ev fd_eqns
; kickOutAfterUnification unifs
; return (insolubleWC residual, not (isEmptyVarSet unifs)) }
+ -- insolubleWC: see (CF3) in Note [Exploiting closed type families]
where
do_fundeps :: UnifyEnv -> TcM ()
do_fundeps env = mapM_ (do_one env) fd_eqns
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f32d29b6546e5275cacd87bc8a5f2e4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f32d29b6546e5275cacd87bc8a5f2e4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
04 Dec '25
recursion-ninja pushed new branch wip/26626 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/26626
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Add support for building bytecode libraries
by Marge Bot (＠marge-bot) 04 Dec '25
by Marge Bot (＠marge-bot) 04 Dec '25
04 Dec '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
7582254c by Matthew Pickering at 2025-12-04T17:14:16-05:00
Add support for building bytecode libraries
A bytecode library is a collection of bytecode files (.gbc) and a
library which combines together additional object files.
A bytecode library is created by invoking GHC with the `-bytecodelib`
flag.
A library can be created from in-memory `ModuleByteCode` linkables or
by passing `.gbc` files as arguments on the command line.
Fixes #26298
- - - - -
84e923eb by Matthew Pickering at 2025-12-04T17:14:17-05:00
Load bytecode libraries to satisfy package dependencies
This commit allows you to use a bytecode library to satisfy a package
dependency when using the interpreter.
If a user enables `-fprefer-byte-code`, then if a package provides a
bytecode library, that will be loaded and used to satisfy the
dependency.
The main change is to separate the relevant parts of the `LoaderState`
into external and home package byte code. Bytecode is loaded into either
the home package or external part (similar to HPT/EPS split), HPT
bytecode can be unloaded. External bytecode is never unloaded.
The unload function has also only been called with an empty list of
"stable linkables" for a long time. It has been modified to directly
implement a complete unloading of the home package bytecode linkables.
At the moment, the bytecode libraries are found in the "library-dirs"
field from the package description. In the future when `Cabal`
implements support for "bytecode-library-dirs" field, we can read the
bytecode libraries from there. No changes to the Cabal submodule are
necessary at the moment.
Four new tests are added in testsuite/tests/cabal, which generate fake
package descriptions and test loading the libraries into GHCi.
Fixes #26298
- - - - -
be7631a4 by mangoiv at 2025-12-04T17:14:23-05:00
ExplicitLevelImports: improve documentation of the code
- more explicit names for variable names like `flg` or `topLevel`
- don't pass the same value twice to functions
- some explanations of interesting but undocumented code paths
- adjust comment to not mention non-existent error message
- - - - -
adb7e06e by mangoiv at 2025-12-04T17:14:29-05:00
driver: don't expect nodes to exist when checking paths between them
In `mgQueryZero`, previously node lookups were expected to never fail,
i.e. it was expected that when calculating the path between two nodes in
a zero level import graph, both nodes would always exist. This is not
the case, e.g. in some situations involving exact names (see the
test-case). The fix is to first check whether the node is present in the
graph at all, instead of panicking, just to report that there is no
path.
Closes #26568
- - - - -
62 changed files:
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session.hs
- + compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- compiler/ghc.cabal.in
- docs/users_guide/phases.rst
- libraries/ghc-boot/GHC/Unit/Database.hs
- testsuite/config/ghc
- testsuite/mk/boilerplate.mk
- + testsuite/tests/cabal/Bytecode.hs
- + testsuite/tests/cabal/BytecodeForeign.c
- + testsuite/tests/cabal/BytecodeForeign.hs
- testsuite/tests/cabal/Makefile
- testsuite/tests/cabal/all.T
- + testsuite/tests/cabal/bytecode.pkg
- + testsuite/tests/cabal/bytecode.script
- + testsuite/tests/cabal/bytecode_foreign.pkg
- + testsuite/tests/cabal/bytecode_foreign.script
- testsuite/tests/cabal/ghcpkg03.stderr
- testsuite/tests/cabal/ghcpkg03.stderr-mingw32
- testsuite/tests/cabal/ghcpkg05.stderr
- testsuite/tests/cabal/ghcpkg05.stderr-mingw32
- + testsuite/tests/cabal/pkg_bytecode.stderr
- + testsuite/tests/cabal/pkg_bytecode.stdout
- + testsuite/tests/cabal/pkg_bytecode_foreign.stderr
- + testsuite/tests/cabal/pkg_bytecode_foreign.stdout
- + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr
- + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout
- + testsuite/tests/cabal/pkg_bytecode_with_o.stderr
- + testsuite/tests/cabal/pkg_bytecode_with_o.stdout
- testsuite/tests/driver/bytecode-object/Makefile
- testsuite/tests/driver/bytecode-object/all.T
- testsuite/tests/driver/bytecode-object/bytecode_object19.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr
- + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout
- + testsuite/tests/th/T26568.hs
- + testsuite/tests/th/T26568.stderr
- testsuite/tests/th/all.T
- utils/ghc-pkg/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d862bf9f9a8dba65abe8998fdc163…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d862bf9f9a8dba65abe8998fdc163…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/26543] Introduce SimplClo and use it [skip ci]
by Simon Peyton Jones (＠simonpj) 04 Dec '25
by Simon Peyton Jones (＠simonpj) 04 Dec '25
04 Dec '25
Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC
Commits:
fa93d8c6 by Simon Peyton Jones at 2025-12-04T17:47:15+00:00
Introduce SimplClo and use it [skip ci]
...especially in ApplyToVal
- - - - -
4 changed files:
- 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/Rep.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.Core.Opt.Simplify.Env (
SimplMode(..), updMode, smPlatform,
-- * Environments
- SimplEnv(..), pprSimplEnv, -- Temp not abstract
+ SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
SimplPhase(..), isActive,
seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
@@ -28,13 +28,13 @@ module GHC.Core.Opt.Simplify.Env (
SimplEnvIS, checkSimplEnvIS, pprBadSimplEnvIS,
-- * Substitution results
- SimplSR(..), mkContEx, substId, lookupRecBndr,
+ SimplClo(..), mkContEx, substId, lookupRecBndr,
-- * Simplifying 'Id' binders
simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
simplBinder, simplBinders,
substTy, substTyVar, getFullSubst, getTCvSubst,
- substCo, substCoVar,
+ substCo, substCoVar, simplCloExpr, simplCloCoercion_maybe,
-- * Floats
SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,
@@ -60,8 +60,9 @@ import GHC.Core.Opt.Arity ( ArityOpts(..) )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Rules.Config ( RuleOpts(..) )
import GHC.Core
+import GHC.Core.Ppr
import GHC.Core.Utils
-import GHC.Core.Subst( substExprSC )
+import GHC.Core.Subst( substExpr )
import GHC.Core.Unfold
import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst)
import GHC.Core.Multiplicity( Scaled(..), mkMultMul )
@@ -209,6 +210,8 @@ type SimplEnvIS = SimplEnv
-- Invariant: the substitution is empty
-- We want this SimplEnv for its InScopeSet and flags
+type StaticEnv = SimplEnv -- Just the static part is relevant
+
checkSimplEnvIS :: SimplEnvIS -> Bool
-- Check the invariant for SimplEnvIS
checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })
@@ -459,41 +462,46 @@ pprSimplEnv env
ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
| otherwise = ppr v
-type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
+type SimplIdSubst = IdEnv SimplClo -- IdId |--> OutExpr
-- See Note [Extending the IdSubstEnv] in GHC.Core.Subst
--- | A substitution result.
-data SimplSR
+-- | A "closure" used in the Simplifier
+-- Roughly: either an (InExpr, StaticEnv) pair for an
+-- as-yet-unsimplified expression
+-- or an OutExpr, for an already-simplified one
+
+data SimplClo
= DoneEx OutExpr JoinPointHood
-- If x :-> DoneEx e ja is in the SimplIdSubst
-- then replace occurrences of x by e
-- and ja = Just a <=> x is a join-point of arity a
-- See Note [Join arity in SimplIdSubst]
-
| DoneId OutId
-- If x :-> DoneId v is in the SimplIdSubst
-- then replace occurrences of x by v
-- and v is a join-point of arity a
-- <=> x is a join-point of arity a
- | ContEx TvSubstEnv -- A suspended substitution
- CvSubstEnv
- SimplIdSubst
+ | ContEx StaticEnv
InExpr
- -- If x :-> ContEx tv cv id e is in the SimplISubst
- -- then replace occurrences of x by (subst (tv,cv,id) e)
+ MOutCoercion -- An /optimised/ OutCoercion
+ -- If x :-> ContEx subst e co is in the SimplISubst
+ -- then replace occurrences of x by ((substExpr subst e) |> co)
-instance Outputable SimplSR where
+instance Outputable SimplClo where
ppr (DoneId v) = text "DoneId" <+> ppr v
- ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
+ ppr (DoneEx e mj) = text "DoneEx" <> pp_mj<> braces (ppr e)
where
pp_mj = case mj of
NotJoinPoint -> empty
JoinPoint n -> parens (int n)
- ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
- ppr (filter_env tv), ppr (filter_env id) -}]
+ ppr (ContEx _se e mco)
+ = text "ContEx" <> vcat [ pprParendExpr e
+ , case mco of
+ MRefl -> empty
+ MCo co -> text "|>" <+> pprOptCo co ]
-- where
-- fvs = exprFreeVars e
-- filter_env env = filterVarEnv_Directly keep env
@@ -627,7 +635,7 @@ reSimplifying :: SimplEnv -> Bool
reSimplifying (SimplEnv { seInlineDepth = n }) = n>0
---------------------
-extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst :: SimplEnv -> Id -> SimplClo -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
= assertPpr (isId var && not (isCoVar var)) (ppr var) $
env { seIdSubst = extendVarEnv subst var res }
@@ -725,8 +733,8 @@ zapSubstEnv env@(SimplEnv { seInlineDepth = n })
setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
-mkContEx :: SimplEnv -> InExpr -> SimplSR
-mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
+mkContEx :: SimplEnv -> InExpr -> SimplClo
+mkContEx env e = ContEx env e MRefl
{-
************************************************************************
@@ -1011,7 +1019,7 @@ So we want to look up the inner X.g_34 in the substitution, where we'll
find that it has been substituted by b. (Or conceivably cloned.)
-}
-substId :: SimplEnv -> InId -> SimplSR
+substId :: SimplEnv -> InId -> SimplClo
-- Returns DoneEx only on a non-Var expression
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
= case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
@@ -1343,17 +1351,29 @@ getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv
getFullSubst :: InScopeSet -> SimplEnv -> Subst
getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })
- = mk_full_subst in_scope tv_env cv_env id_env
-
-mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst
-mk_full_subst in_scope tv_env cv_env id_env
- = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env
- where
- to_expr :: SimplSR -> CoreExpr
- -- A tiresome impedence-matcher
- to_expr (DoneEx e _) = e
- to_expr (DoneId v) = Var v
- to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e
+ = mkSubst in_scope (mapVarEnv (simplCloExpr in_scope) id_env) tv_env cv_env
+
+simplCloExpr :: InScopeSet -> SimplClo -> OutExpr
+simplCloExpr _ (DoneEx e _) = e
+simplCloExpr _ (DoneId v) = Var v
+simplCloExpr in_scope (ContEx se e mco) = mkCastMCo e' mco
+ where
+ e' = GHC.Core.Subst.substExpr (getFullSubst in_scope se) e
+ -- Make sure we apply the static environment `sc_env` as a substitution
+ -- to get an OutExpr. See (BF1) in Note [tryRules: plan (BEFORE)]
+ -- in GHC.Core.Opt.Simplify.Iteration
+ -- NB: we use substExpr, not substExprSC: we want to get the benefit of
+ -- knowing what is evaluated etc, via the in-scope set
+
+simplCloCoercion_maybe :: SimplClo -> Maybe OutCoercion
+-- If the closure is just a coercion, give it to me
+simplCloCoercion_maybe clo
+ = case clo of
+ DoneEx (Coercion co) _ -> Just co
+ ContEx se (Coercion co) MRefl -> Just (substCo se co)
+ -- Do we ever cast a coercion??
+ DoneId {} -> Nothing -- Coercion variables never occur naked
+ _ -> Nothing
substTy :: HasDebugCallStack => SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getTCvSubst env) ty
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -278,8 +278,8 @@ simplRecOrTopPair :: SimplEnv
-> SimplM (SimplFloats, SimplEnv)
simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
- | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)
- old_bndr rhs env
+ | Just env' <- preInlineLetUnconditionally env (bindContextLevel bind_cxt)
+ old_bndr rhs env
= {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}
simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $
do { tick (PreInlineUnconditionally old_bndr)
@@ -1211,7 +1211,7 @@ simplExprF1 env (App fun arg) cont
-- observed the quadratic behavior, so this extra entanglement
-- seems not worthwhile.
simplExprF env fun $
- ApplyToVal { sc_arg = arg, sc_env = env
+ ApplyToVal { sc_arg = mkContEx env arg
, sc_hole_ty = substTy env (exprType fun)
, sc_dup = NoDup, sc_cont = cont }
@@ -1249,7 +1249,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
do { ty' <- simplType env ty
; simplExprF (extendTvSubst env bndr ty') body cont }
- | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
+ | Just env' <- preInlineLetUnconditionally env NotTopLevel bndr rhs env
-- Because of the let-can-float invariant, it's ok to
-- inline freely, or to drop the binding if it is dead.
= do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $
@@ -1266,7 +1266,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
| otherwise
= {-#SCC "simplNonRecE" #-}
- simplNonRecE env FromLet bndr (rhs, env) body cont
+ simplNonRecE env FromLet bndr (mkContEx env rhs) body cont
{- Note [Avoiding space leaks in OutType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1549,10 +1549,9 @@ rebuild_go env expr cont
ApplyToTy { sc_arg_ty = ty, sc_cont = cont}
-> rebuild_go env (App expr (Type ty)) cont
- ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag
- , sc_cont = cont, sc_hole_ty = fun_ty }
+ ApplyToVal { sc_arg = arg_clo, sc_cont = cont, sc_hole_ty = fun_ty }
-- See Note [Avoid redundant simplification]
- -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg
+ -> do { arg' <- simplClo env fun_ty Nothing arg_clo
; rebuild_go env (App expr arg') cont }
completeBindX :: SimplEnv
@@ -1709,7 +1708,7 @@ simplCast env body co0 cont0
-- where co :: (s1->s2) ~ (t1->t2)
-- co1 :: t1 ~ s1
-- co2 :: s2 ~ t2
- addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
+ addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg_clo
, sc_dup = dup, sc_cont = tail
, sc_hole_ty = fun_ty })
| not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first
@@ -1724,15 +1723,13 @@ simplCast env body co0 cont0
-- See Note [Avoiding simplifying repeatedly]
MCo co1 ->
- do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg
- -- When we build the ApplyTo we can't mix the OutCoercion
- -- 'co' with the InExpr 'arg', so we simplify
- -- to make it all consistent. It's a bit messy.
- -- But it isn't a common case.
- -- Example of use: #995
- ; return (ApplyToVal { sc_arg = mkCast arg' co1
- , sc_env = arg_se'
- , sc_dup = dup'
+ do { let arg_clo' = case arg_clo of
+ DoneId v -> DoneEx (Cast (Var v) co1) NotJoinPoint
+ DoneEx e _jp -> DoneEx (Cast e co1) NotJoinPoint
+ ContEx se e mco -> ContEx se e (mkTransMCoL mco co1)
+
+ ; return (ApplyToVal { sc_arg = arg_clo'
+ , sc_dup = dup
, sc_cont = tail'
, sc_hole_ty = coercionLKind co }) } } }
@@ -1742,28 +1739,25 @@ simplCast env body co0 cont0
-- See Note [Optimising reflexivity]
| otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont })
-simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet
- -> DupFlag
- -> OutType -- ^ Type of the function applied to this arg
- -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app
- -- `f a1 ... an` where we have ArgInfo on
- -- how `f` uses `ai`, affecting the Stop
- -- continuation passed to 'simplExprC'
- -> StaticEnv -> CoreExpr -- ^ Expression with its static envt
- -> SimplM (DupFlag, StaticEnv, OutExpr)
-simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg
- | isSimplified dup_flag
- = return (dup_flag, arg_env, arg)
- | otherwise
- = do { let arg_env' = arg_env `setInScopeFromE` env
- ; let arg_ty = funArgTy fun_ty
- ; let stop = case mb_arg_info of
- Nothing -> mkBoringStop arg_ty
- Just ai -> mkLazyArgStop arg_ty ai
- ; arg' <- simplExprC arg_env' arg stop
- ; return (Simplified, zapSubstEnv arg_env', arg') }
- -- Return a StaticEnv that includes the in-scope set from 'env',
- -- because arg' may well mention those variables (#20639)
+simplClo :: SimplEnvIS -- ^ Used only for its InScopeSet
+ -> OutType -- ^ Type of the function applied to this arg
+ -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app
+ -- `f a1 ... an` where we have ArgInfo on
+ -- how `f` uses `ai`, affecting the Stop
+ -- continuation passed to 'simplExprC'
+ -> SimplClo
+ -> SimplM OutExpr
+simplClo env fun_ty mb_arg_info (ContEx arg_se arg mco)
+ = simplExprC arg_env arg stop
+ where
+ arg_env = arg_se `setInScopeFromE` env
+ arg_ty = funArgTy fun_ty
+ stop = case mb_arg_info of
+ Nothing -> mkBoringStop arg_ty
+ Just ai -> mkLazyArgStop arg_ty ai
+
+simplClo _ _ _ (DoneEx e _) = return e
+simplClo _ _ _ (DoneId v) = return (Var v)
{-
************************************************************************
@@ -1797,16 +1791,15 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
; simplLam (extendTvSubst env bndr arg_ty) body cont }
-- Coercion beta-reduction
-simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se
- , sc_cont = cont })
+simpl_lam env bndr body (ApplyToVal { sc_arg = arg_clo, sc_cont = cont })
+ | Just out_co <- simplCloCoercion_maybe arg_clo
= assertPpr (isCoVar bndr) (ppr bndr) $
do { tick (BetaReduction bndr)
- ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co
- ; simplLam (extendCvSubst env bndr arg_co') body cont }
+ ; simplLam (extendCvSubst env bndr out_co) body cont }
-- Value beta-reduction
-- This works for /coercion/ lambdas too
-simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se
+simpl_lam env bndr body (ApplyToVal { sc_arg = arg_clo
, sc_cont = cont, sc_dup = dup
, sc_hole_ty = fun_ty})
= do { tick (BetaReduction bndr)
@@ -1823,24 +1816,13 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se
-- It's wrong to err in either direction
-- But fun_ty is an OutType, so is fully substituted
- ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se
- , not (needsCaseBindingL arg_levity arg)
- -- Ok to test arg::InExpr in needsCaseBinding because
- -- exprOkForSpeculation is stable under simplification
- , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly]
- not (exprIsTrivial arg) &&
- not (isDeadOcc (idOccInfo bndr)) )
+ ; if | Just env' <- preInlineBetaUnconditionally env arg_levity bndr arg_clo
-> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $
tick (PreInlineUnconditionally bndr)
; simplLam env' body cont }
- | isSimplified dup -- Don't re-simplify if we've simplified it once
- -- Including don't preInlineUnconditionally
- -- See Note [Avoiding simplifying repeatedly]
- -> completeBindX env from_what bndr arg body cont
-
| otherwise
- -> simplNonRecE env from_what bndr (arg, arg_se) body cont }
+ -> simplNonRecE env from_what bndr arg_clo body cont }
-- Discard a non-counting tick on a lambda. This may change the
-- cost attribution slightly (moving the allocation of the
@@ -1876,8 +1858,7 @@ simplNonRecE :: HasDebugCallStack
-> FromWhat
-> InId -- The binder, always an Id
-- Never a join point
- -- The static env for its unfolding (if any) is the first parameter
- -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
+ -> SimplClo -- Rhs of binding (or arg of lambda)
-> InExpr -- Body of the let/lambda
-> SimplCont
-> SimplM (SimplFloats, OutExpr)
@@ -1896,7 +1877,14 @@ simplNonRecE :: HasDebugCallStack
-- from_what=FromLet => the RHS satisfies the let-can-float invariant
-- Otherwise it may or may not satisfy it.
-simplNonRecE env from_what bndr (rhs, rhs_se) body cont
+simplNonRecE env from_what bndr (DoneEx rhs jp) body cont
+ = assertPpr (jp == NotJoinPoint) (ppr bndr) $
+ completeBindX env from_what bndr rhs body cont
+
+simplNonRecE env from_what bndr (DoneId v) body cont
+ = completeBindX env from_what bndr (Var v) body cont
+
+simplNonRecE env from_what bndr (ContEx rhs_se rhs mco) body cont
| assert (isId bndr && not (isJoinId bndr) ) $
is_strict_bind
= -- Evaluate RHS strictly
@@ -2237,10 +2225,10 @@ simplInVar env var
| isCoVar var = return $! Coercion $! (substCoVar env var)
| otherwise
= case substId env var of
- ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids
- in simplExpr env' e
- DoneId var1 -> return (Var var1)
- DoneEx e _ -> return e
+ ContEx se e mco -> do { e' <- simplExpr (se `setInScopeFromE` env) e
+ ; return (mkCastMCo e' mco) }
+ DoneId var1 -> return (Var var1)
+ DoneEx e _ -> return e
simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplInId env var cont
@@ -2249,19 +2237,16 @@ simplInId env var cont
= rebuild zapped_env (Var var) cont
| otherwise
= case substId env var of
- ContEx tvs cvs ids e -> simplExprF env' e cont
- -- Don't trimJoinCont; haven't already simplified e,
+ ContEx se e mco -> do { e' <- simplExprF (se `setInScopeFromE` env) e cont
+ ; return (mkCastMCo e' mco) }
+ -- Don't trimJoinCont; we haven't already simplified e,
-- so the cont is not embodied in e
- where
- env' = setSubstEnv env tvs cvs ids
- DoneId out_id -> simplOutId zapped_env out_id cont'
- where
- cont' = trimJoinCont out_id (idJoinPointHood out_id) cont
+ DoneId out_id -> simplOutId zapped_env out_id $
+ trimJoinCont out_id (idJoinPointHood out_id) cont
- DoneEx e mb_join -> simplExprF zapped_env e cont'
- where
- cont' = trimJoinCont var mb_join cont
+ DoneEx e mb_join -> simplExprF zapped_env e $
+ trimJoinCont var mb_join cont
where
zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
@@ -2277,8 +2262,8 @@ simplOutId env fun cont
| fun `hasKey` runRWKey
, ApplyToTy { sc_cont = cont1 } <- cont
, ApplyToTy { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1
- , ApplyToVal { sc_cont = cont3, sc_arg = arg
- , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2
+ , ApplyToVal { sc_cont = cont3, sc_arg = arg_clo
+ , sc_hole_ty = fun_ty } <- cont2
-- Do this even if (contIsStop cont), or if seCaseCase is off.
-- See Note [No eta-expansion in runRW#]
= do { let arg_env = arg_se `setInScopeFromE` env
@@ -2306,8 +2291,8 @@ simplOutId env fun cont
_ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
env' = arg_env `addNewInScopeIds` [s']
- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
- , sc_env = env', sc_cont = inner_cont
+ cont' = ApplyToVal { sc_dup = Dupable, sc_arg = DoneId s'
+ , sc_cont = inner_cont
, sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }
-- cont' applies to s', then K
; body' <- simplExprC env' arg cont'
@@ -2386,32 +2371,36 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
---------- Simplify value arguments --------------------
rebuildCall env fun_info
- (ApplyToVal { sc_arg = arg, sc_env = arg_se
+ (ApplyToVal { sc_arg = arg_clo
, sc_dup = dup_flag, sc_hole_ty = fun_ty
, sc_cont = cont })
- -- Argument is already simplified
- | isSimplified dup_flag -- See Note [Avoid redundant simplification]
- = rebuildCall env (addValArgTo fun_info arg fun_ty) cont
-
- -- Strict arguments
- | isStrictArgInfo fun_info
- , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
- -- Note [Case-of-case and full laziness]
- = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
- simplExprF (arg_se `setInScopeFromE` env) arg
- (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
- , sc_dup = Simplified
- , sc_cont = cont })
+ = case arg_clo of -- See Note [Avoid redundant simplification]
+ DoneId v -> rebuildCall env (addValArgTo fun_info (Var v) fun_ty) cont
+ DoneEx arg _ -> rebuildCall env (addValArgTo fun_info arg fun_ty) cont
+ ContEx arg_se in_arg mco
+ -- Strict arguments
+ | isStrictArgInfo fun_info
+ , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
+ -> simplExprF (arg_se `setInScopeFromE` env) in_arg
+ (add_cast mco $
+ StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
+ , sc_dup = NoDup, sc_cont = cont })
-- Note [Shadowing in the Simplifier]
- -- Lazy arguments
- | otherwise
+ -- Lazy arguments
+ | otherwise
-- DO NOT float anything outside, hence simplExprC
-- There is no benefit (unlike in a let-binding), and we'd
-- have to be very careful about bogus strictness through
-- floating a demanded let.
- = do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg
- ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
+ -> do { arg' <- simplClo env fun_ty (Just fun_info) arg_clo
+ ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
+
+ where
+ add_cast MRefl cont = cont
+ add_cast (MCo co) cont = CastIt { sc_co = co, sc_opt = True, sc_cont = cont }
+
---------- No further useful info, revert to generic rebuild ------------
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
@@ -2436,7 +2425,7 @@ tryInlining env logger var cont
= return Nothing
where
- (lone_variable, arg_infos, call_cont) = contArgs cont
+ (lone_variable, arg_infos, call_cont) = contArgs env cont
interesting_cont = interestingCallContext env call_cont
log_inlining doc
@@ -2644,7 +2633,7 @@ tryRules env rules fn args
--, text "Rule activation:" <+> ppr (ruleActivation rule)
, text "Full arity:" <+> ppr (ruleArity rule)
, text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
- , text "After: " <+> pprCoreExpr rule_rhs ]
+ , text "After: " <+> mkApps (pprCoreExpr rule_rhs) (drop (ruleArity rule) args) ]
| logHasDumpFlag logger Opt_D_dump_rule_firings
= log_rule Opt_D_dump_rule_firings "Rule fired:" $
@@ -2713,8 +2702,8 @@ trySeqRules in_env scrut rhs cont
, ValArg { as_arg = no_cast_scrut
, as_dmd = seqDmd
, as_hole_ty = res3_ty } ]
- rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
- , sc_env = in_env, sc_cont = cont
+ rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = mkContEx in_env rhs
+ , sc_cont = cont
, sc_hole_ty = res4_ty }
-- Lazily evaluated, so we don't do most of this
@@ -3941,7 +3930,7 @@ mkDupableContWithDmds env dmds
, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
mkDupableContWithDmds env dmds
- (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
+ (ApplyToVal { sc_arg = arg_clo, sc_dup = dup
, sc_cont = cont, sc_hole_ty = hole_ty })
= -- e.g. [...hole...] (...arg...)
-- ==>
@@ -3951,16 +3940,11 @@ mkDupableContWithDmds env dmds
do { let dmd:|cont_dmds = expectNonEmpty dmds
; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont
; let env' = env `setInScopeFromF` floats1
- ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg
+ ; arg' <- simplClo env' hole_ty Nothing arg_clo
; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'
; let all_floats = floats1 `addLetFloats` let_floats2
; return ( all_floats
- , ApplyToVal { sc_arg = arg''
- , sc_env = se' `setInScopeFromF` all_floats
- -- Ensure that sc_env includes the free vars of
- -- arg'' in its in-scope set, even if makeTrivial
- -- has turned arg'' into a fresh variable
- -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
+ , ApplyToVal { sc_arg = DoneEx arg'' NotJoinPoint
, sc_dup = OkToDup, sc_cont = cont'
, sc_hole_ty = hole_ty }) }
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -12,7 +12,9 @@ module GHC.Core.Opt.Simplify.Utils (
tryEtaExpandRhs, wantEtaExpansion,
-- Inlining,
- preInlineUnconditionally, postInlineUnconditionally,
+ preInlineLetUnconditionally,
+ preInlineBetaUnconditionally,
+ postInlineUnconditionally,
activeRule,
getUnfoldingInRuleMatch,
updModeForStableUnfoldings, updModeForRuleLHS, updModeForRuleRHS,
@@ -173,8 +175,7 @@ data SimplCont
{ sc_dup :: DupFlag -- See Note [DupFlag invariants]
, sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah)
-- See Note [The hole type in ApplyToTy]
- , sc_arg :: InExpr -- The argument,
- , sc_env :: StaticEnv -- see Note [StaticEnv invariant]
+ , sc_arg :: SimplClo -- The argument
, sc_cont :: SimplCont }
| ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ]
@@ -216,23 +217,17 @@ data SimplCont
CoreTickish -- Tick tickish <hole>
SimplCont
-type StaticEnv = SimplEnv -- Just the static part is relevant
data FromWhat = FromLet | FromBeta Levity
-- See Note [DupFlag invariants]
data DupFlag = NoDup -- Unsimplified, might be big
- | Simplified -- Simplified
| OkToDup -- Simplified and small
isSimplified :: DupFlag -> Bool
isSimplified NoDup = False
isSimplified _ = True -- Invariant: the subst-env is empty
-perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type
-perhapsSubstTy dup env ty
- | isSimplified dup = ty
- | otherwise = substTy env ty
{- Note [StaticEnv invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -255,21 +250,16 @@ the expression, and that (rightly) gives ASSERT failures if the InScopeSet
isn't big enough.
Note [DupFlag invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k}
and Select { se_dup = dup, se_env = env, se_cont = k}
-the following invariants hold
-
- (a) if dup = OkToDup, then continuation k is also ok-to-dup
- (b) if dup = OkToDup or Simplified, the subst-env is empty,
- or at least is always ignored; the payload is
- already an OutThing
+the following invariant holds
+ if dup = OkToDup, then continuation k is also ok-to-dup
-}
instance Outputable DupFlag where
ppr OkToDup = text "ok"
ppr NoDup = text "nodup"
- ppr Simplified = text "simpl"
instance Outputable SimplCont where
ppr (Stop ty interesting eval_sd)
@@ -284,7 +274,7 @@ instance Outputable SimplCont where
= (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })
= (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty)
- 2 (pprParendExpr arg))
+ 2 (ppr arg))
$$ ppr cont
ppr (StrictBind { sc_bndr = b, sc_cont = cont })
= (text "StrictBind" <+> ppr b) $$ ppr cont
@@ -392,9 +382,8 @@ pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args
pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont
pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont
= ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }
-pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
- = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
- -- The SubstEnv will be ignored since sc_dup=Simplified
+pushSimplifiedArg _env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
+ = ApplyToVal { sc_arg = DoneEx arg NotJoinPoint, sc_dup = NoDup
, sc_hole_ty = hole_ty, sc_cont = cont }
argSpecArg :: ArgSpec -> OutExpr
@@ -475,14 +464,17 @@ contHoleType :: SimplCont -> OutType
contHoleType (Stop ty _ _) = ty
contHoleType (TickIt _ k) = contHoleType k
contHoleType (CastIt { sc_co = co }) = coercionLKind co
-contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
- = perhapsSubstTy dup se (idType b)
contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty
contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]
contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]
-contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
- = perhapsSubstTy d se (idType b)
+contHoleType (StrictBind { sc_bndr = b, sc_dup = d, sc_env = se }) = perhapsSubstIdTy d se b
+contHoleType (Select { sc_bndr = b, sc_dup = d, sc_env = se }) = perhapsSubstIdTy d se b
+perhapsSubstIdTy :: DupFlag -> StaticEnv -> Id -> Type
+perhapsSubstIdTy dup_flag env bndr
+ = case dup_flag of
+ OkToDup -> idType bndr -- The Id is an OutId
+ NoDup -> substTy env (idType bndr) -- The Id is an InId
-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of
-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling
@@ -525,11 +517,11 @@ countValArgs (CastIt { sc_cont = cont }) = countValArgs cont
countValArgs _ = 0
-------------------
-contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
+contArgs :: SimplEnv -> SimplCont -> (Bool, [ArgSummary], SimplCont)
-- Summarises value args, discards type args and coercions
-- The returned continuation of the call is only used to
-- answer questions like "are you interesting?"
-contArgs cont
+contArgs env cont
| lone cont = (True, [], cont)
| otherwise = go [] cont
where
@@ -538,34 +530,22 @@ contArgs cont
lone (CastIt {}) = False -- stops it being "lone"
lone _ = True
- go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })
- = go (is_interesting arg se : args) k
+ go args (ApplyToVal { sc_arg = arg_clo, sc_cont = k })
+ = go (interestingArg env arg_clo : args) k
go args (ApplyToTy { sc_cont = k }) = go args k
go args (CastIt { sc_cont = k }) = go args k
go args k = (False, reverse args, k)
- is_interesting arg se = interestingArg se arg
- -- Do *not* use short-cutting substitution here
- -- because we want to get as much IdInfo as possible
-
contOutArgs :: SimplEnv -> SimplCont -> [OutExpr]
-- Get the leading arguments from the `SimplCont`, as /OutExprs/
contOutArgs env cont
= go cont
where
- in_scope = seInScope env
-
go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })
= Type ty : go cont
- go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont })
- | isSimplified dup = arg : go cont
- | otherwise = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont
- -- Make sure we apply the static environment `sc_env` as a substitution
- -- to get an OutExpr. See (BF1) in Note [tryRules: plan (BEFORE)]
- -- in GHC.Core.Opt.Simplify.Iteration
- -- NB: we use substExpr, not substExprSC: we want to get the benefit of
- -- knowing what is evaluated etc, via the in-scope set
+ go (ApplyToVal { sc_arg = arg_clo, sc_cont = cont })
+ = simplCloExpr (seInScope env) arg_clo : go cont
-- No more arguments
go _ = []
@@ -993,16 +973,18 @@ rule for (*) (df d) can fire. To do this
b) we say that a con-like argument (eg (df d)) is interesting
-}
-interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
+interestingArg :: SimplEnv -> SimplClo -> ArgSummary
-- See Note [Interesting arguments]
-interestingArg env e = go env 0 e
+-- Do *not* use short-cutting substitution here
+-- because we want to get as much IdInfo as possible
+interestingArg env e = go_clo env 0 e
where
+ go_clo _env n (DoneId v) = go_var n v
+ go_clo env n (DoneEx e _) = go (zapSubstEnv env) n e
+ go_clo env n (ContEx se e _co) = go (se `setInScopeFromE` env) n e
+
-- n is # value args to which the expression is applied
- go env n (Var v)
- = case substId env v of
- DoneId v' -> go_var n v'
- DoneEx e _ -> go (zapSubstEnv env) n e
- ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
+ go env n (Var v) = go_clo env n (substId env v)
go _ _ (Lit l)
| isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035
@@ -1490,7 +1472,38 @@ is a term (not a coercion) so we can't necessarily inline the latter in
the former.
-}
-preInlineUnconditionally
+
+preInlineBetaUnconditionally
+ :: SimplEnv -> Levity -> InId -> SimplClo
+ -> Maybe SimplEnv -- Returned env has extended substitution
+preInlineBetaUnconditionally env levity bndr clo
+ | not pre_inline_unconditionally = Nothing
+ | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]
+ | not (one_occ (idOccInfo bndr)) = Nothing
+ | needs_case_binding levity = Nothing
+ | otherwise = Just $! extendIdSubst env bndr clo
+ where
+ pre_inline_unconditionally = sePreInline env
+
+ one_occ OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam }
+ = True
+ one_occ OneOcc{ occ_n_br = 1, occ_in_lam = IsInsideLam, occ_int_cxt = IsInteresting }
+ = case clo of
+ ContEx _ rhs _ -> canInlineInLam rhs
+ DoneId {} -> True
+ DoneEx rhs _ -> exprIsTrivial rhs
+ one_occ IAmDead = True -- Happens in ((\x.1) v)
+ one_occ _ = False
+
+ -- NB: exprOkForSpeculation is stable under substitution
+ -- so we can apply it to an InExpr in the ContEx case
+ needs_case_binding Lifted = False
+ needs_case_binding Unlifted = case clo of
+ DoneId {} -> False
+ DoneEx e _ -> exprOkForSpeculation e
+ ContEx _ e _ -> exprOkForSpeculation e
+
+preInlineLetUnconditionally
:: SimplEnv -> TopLevelFlag -> InId
-> InExpr -> StaticEnv -- These two go together
-> Maybe SimplEnv -- Returned env has extended substitution
@@ -1498,7 +1511,7 @@ preInlineUnconditionally
-- See Note [Core let-can-float invariant] in GHC.Core
-- Reason: we don't want to inline single uses, or discard dead bindings,
-- for unlifted, side-effect-ful bindings
-preInlineUnconditionally env top_lvl bndr rhs rhs_env
+preInlineLetUnconditionally 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]
@@ -1516,13 +1529,12 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
unf = idUnfolding bndr
extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
+ one_occ OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam }
+ = isNotTopLevel top_lvl || early_phase
+ one_occ OneOcc{ occ_n_br = 1, occ_in_lam = IsInsideLam, occ_int_cxt = IsInteresting }
+ = canInlineInLam rhs
one_occ IAmDead = True -- Happens in ((\x.1) v)
- one_occ OneOcc{ occ_n_br = 1
- , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase
- one_occ OneOcc{ occ_n_br = 1
- , occ_in_lam = IsInsideLam
- , occ_int_cxt = IsInteresting } = canInlineInLam rhs
- one_occ _ = False
+ one_occ _ = False
pre_inline_unconditionally = sePreInline env
active = isActive (sePhase env)
@@ -1530,38 +1542,6 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
-- See Note [pre/postInlineUnconditionally in gentle mode]
inline_prag = idInlinePragma bndr
--- Be very careful before inlining inside a lambda, because (a) we must not
--- invalidate occurrence information, and (b) we want to avoid pushing a
--- single allocation (here) into multiple allocations (inside lambda).
--- Inlining a *function* with a single *saturated* call would be ok, mind you.
--- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
--- where
--- is_cheap = exprIsCheap rhs
--- ok = is_cheap && int_cxt
-
- -- int_cxt The context isn't totally boring
- -- E.g. let f = \ab.BIG in \y. map f xs
- -- Don't want to substitute for f, because then we allocate
- -- its closure every time the \y is called
- -- But: let f = \ab.BIG in \y. map (f y) xs
- -- Now we do want to substitute for f, even though it's not
- -- saturated, because we're going to allocate a closure for
- -- (f y) every time round the loop anyhow.
-
- -- 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
- -- not ticks. Counting ticks cannot be duplicated, and non-counting
- -- ticks around a Lam will disappear anyway.
early_phase =
case sePhase env of
@@ -1593,6 +1573,39 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
-- (Nor can we check for `exprIsExpandable rhs`, because that needs to look
-- at the non-existent unfolding for the `I# 2#` which is also floated out.)
+canInlineInLam :: CoreExpr -> Bool
+-- Be very careful before inlining inside a lambda, because (a) we must not
+-- invalidate occurrence information, and (b) we want to avoid pushing a
+-- single allocation (here) into multiple allocations (inside lambda).
+-- Inlining a *function* with a single *saturated* call would be ok, mind you.
+-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
+-- where
+-- is_cheap = exprIsCheap rhs
+-- ok = is_cheap && int_cxt
+ -- int_cxt The context isn't totally boring
+ -- E.g. let f = \ab.BIG in \y. map f xs
+ -- Don't want to substitute for f, because then we allocate
+ -- its closure every time the \y is called
+ -- But: let f = \ab.BIG in \y. map (f y) xs
+ -- Now we do want to substitute for f, even though it's not
+ -- saturated, because we're going to allocate a closure for
+ -- (f y) every time round the loop anyhow.
+
+ -- 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
+ -- not ticks. Counting ticks cannot be duplicated, and non-counting
+ -- ticks around a Lam will disappear anyway.
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1022,7 +1022,7 @@ instance NFData CoSel where
instance Outputable MCoercion where
ppr MRefl = text "MRefl"
- ppr (MCo co) = text "MCo" <+> ppr co
+ ppr (MCo co) = text "MCo" <> braces (ppr co)
{- Note [Refl invariant]
~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa93d8c6338267c17ba6498d0b2da95…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa93d8c6338267c17ba6498d0b2da95…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/hadrian-with_profiled_libs] hadrian: add with_profiled_libs flavour transformer
by Cheng Shao (＠TerrorJack) 04 Dec '25
by Cheng Shao (＠TerrorJack) 04 Dec '25
04 Dec '25
Cheng Shao pushed to branch wip/hadrian-with_profiled_libs at Glasgow Haskell Compiler / GHC
Commits:
27e796af by Cheng Shao at 2025-12-04T18:16:25+01:00
hadrian: add with_profiled_libs flavour transformer
This patch adds a `with_profiled_libs` flavour transformer to hadrian
which is the exact opposite of `no_profiled_libs`. It adds profiling
ways to rts/library ways, and doesn't alter other flavour settings. It
is useful when needing to test profiling logic locally with a quick
flavour.
- - - - -
2 changed files:
- hadrian/doc/flavours.md
- hadrian/src/Flavour.hs
Changes:
=====================================
hadrian/doc/flavours.md
=====================================
@@ -270,6 +270,10 @@ The supported transformers are listed below:
<td><code>text_simdutf</code></td>
<td>Enable building the <code>text</code> package with <code>simdutf</code> support.</td>
</tr>
+ <tr>
+ <td><code>with_profiled_libs</code></td>
+ <td>Enables building of libraries and the RTS in profiled build ways (the opposite of <code>no_profiled_libs</code>).</td>
+ </tr>
<tr>
<td><code>no_profiled_libs</code></td>
<td>Disables building of libraries in profiled build ways.</td>
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -14,6 +14,7 @@ module Flavour
, enableProfiledGhc
, disableDynamicGhcPrograms
, disableDynamicLibs
+ , enableProfiledLibs
, disableProfiledLibs
, enableLinting
, enableHaddock
@@ -59,6 +60,7 @@ flavourTransformers = M.fromList
, "no_dynamic_libs" =: disableDynamicLibs
, "native_bignum" =: useNativeBignum
, "text_simdutf" =: enableTextWithSIMDUTF
+ , "with_profiled_libs" =: enableProfiledLibs
, "no_profiled_libs" =: disableProfiledLibs
, "omit_pragmas" =: omitPragmas
, "ipe" =: enableIPE
@@ -301,6 +303,17 @@ disableDynamicLibs flavour =
prune :: Ways -> Ways
prune = fmap $ Set.filter (not . wayUnit Dynamic)
+-- | Build libraries and the RTS in profiled ways (opposite of
+-- 'disableProfiledLibs').
+enableProfiledLibs :: Flavour -> Flavour
+enableProfiledLibs flavour =
+ flavour
+ { libraryWays = addProfilingWays $ libraryWays flavour
+ , rtsWays = addProfilingWays $ rtsWays flavour
+ }
+ where
+ addProfilingWays :: Ways -> Ways
+ addProfilingWays ways = fmap (\ws -> ws <> Set.map (<> profiling) ws) ways
-- | Don't build libraries in profiled 'Way's.
disableProfiledLibs :: Flavour -> Flavour
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27e796af94cda5fa4aaac2156bd16f0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27e796af94cda5fa4aaac2156bd16f0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/hadrian-with_profiled_libs
by Cheng Shao (＠TerrorJack) 04 Dec '25
by Cheng Shao (＠TerrorJack) 04 Dec '25
04 Dec '25
Cheng Shao pushed new branch wip/hadrian-with_profiled_libs at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/hadrian-with_profiled_libs
You're receiving this email because of your account on gitlab.haskell.org.
1
0
04 Dec '25
Teo Camarasu pushed to branch wip/T26625 at Glasgow Haskell Compiler / GHC
Commits:
9bd917d8 by Teo Camarasu at 2025-12-04T16:18:42+00:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
5 changed files:
- libraries/base/src/GHC/Num.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/GHC/Num.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
@@ -16,11 +17,190 @@ module GHC.Num
( Num(..)
, subtract
, quotRemInteger
- , module GHC.Num.Integer
- , module GHC.Num.Natural
+ , integerFromNatural
+ , integerToNaturalClamp
+ , integerToNaturalThrow
+ , integerToNatural
+ , integerToWord#
+ , integerToInt#
+ , integerToWord64#
+ , integerToInt64#
+ , integerAdd
+ , integerMul
+ , integerSub
+ , integerNegate
+ , integerAbs
+ , integerPopCount#
+ , integerQuot
+ , integerRem
+ , integerDiv
+ , integerMod
+ , integerDivMod#
+ , integerQuotRem#
+ , integerEncodeFloat#
+ , integerEncodeDouble#
+ , integerGcd
+ , integerLcm
+ , integerAnd
+ , integerOr
+ , integerXor
+ , integerComplement
+ , integerBit#
+ , integerTestBit#
+ , integerShiftL#
+ , integerShiftR#
+ , integerFromWord#
+ , integerFromWord64#
+ , integerFromInt64#
+ , Integer(..)
+ , integerBit
+ , integerCheck
+ , integerCheck#
+ , integerCompare
+ , integerDecodeDouble#
+ , integerDivMod
+ , integerEncodeDouble
+ , integerEq
+ , integerEq#
+ , integerFromAddr
+ , integerFromAddr#
+ , integerFromBigNat#
+ , integerFromBigNatNeg#
+ , integerFromBigNatSign#
+ , integerFromByteArray
+ , integerFromByteArray#
+ , integerFromInt
+ , integerFromInt#
+ , integerFromWord
+ , integerFromWordList
+ , integerFromWordNeg#
+ , integerFromWordSign#
+ , integerGcde
+ , integerGcde#
+ , integerGe
+ , integerGe#
+ , integerGt
+ , integerGt#
+ , integerIsNegative
+ , integerIsNegative#
+ , integerIsOne
+ , integerIsPowerOf2#
+ , integerIsZero
+ , integerLe
+ , integerLe#
+ , integerLog2
+ , integerLog2#
+ , integerLogBase
+ , integerLogBase#
+ , integerLogBaseWord
+ , integerLogBaseWord#
+ , integerLt
+ , integerLt#
+ , integerNe
+ , integerNe#
+ , integerOne
+ , integerPowMod#
+ , integerQuotRem
+ , integerRecipMod#
+ , integerShiftL
+ , integerShiftR
+ , integerSignum
+ , integerSignum#
+ , integerSizeInBase#
+ , integerSqr
+ , integerTestBit
+ , integerToAddr
+ , integerToAddr#
+ , integerToBigNatClamp#
+ , integerToBigNatSign#
+ , integerToInt
+ , integerToMutableByteArray
+ , integerToMutableByteArray#
+ , integerToWord
+ , integerZero
+ , naturalToWord#
+ , naturalPopCount#
+ , naturalShiftR#
+ , naturalShiftL#
+ , naturalAdd
+ , naturalSub
+ , naturalSubThrow
+ , naturalSubUnsafe
+ , naturalMul
+ , naturalQuotRem#
+ , naturalQuot
+ , naturalRem
+ , naturalAnd
+ , naturalAndNot
+ , naturalOr
+ , naturalXor
+ , naturalTestBit#
+ , naturalBit#
+ , naturalGcd
+ , naturalLcm
+ , naturalLog2#
+ , naturalLogBaseWord#
+ , naturalLogBase#
+ , naturalPowMod
+ , naturalSizeInBase#
+ , Natural(..)
+ , naturalBit
+ , naturalCheck
+ , naturalCheck#
+ , naturalClearBit
+ , naturalClearBit#
+ , naturalCompare
+ , naturalComplementBit
+ , naturalComplementBit#
+ , naturalEncodeDouble#
+ , naturalEncodeFloat#
+ , naturalEq
+ , naturalEq#
+ , naturalFromAddr
+ , naturalFromAddr#
+ , naturalFromBigNat#
+ , naturalFromByteArray#
+ , naturalFromWord
+ , naturalFromWord#
+ , naturalFromWord2#
+ , naturalFromWordList
+ , naturalGe
+ , naturalGe#
+ , naturalGt
+ , naturalGt#
+ , naturalIsOne
+ , naturalIsPowerOf2#
+ , naturalIsZero
+ , naturalLe
+ , naturalLe#
+ , naturalLog2
+ , naturalLogBase
+ , naturalLogBaseWord
+ , naturalLt
+ , naturalLt#
+ , naturalNe
+ , naturalNe#
+ , naturalNegate
+ , naturalOne
+ , naturalPopCount
+ , naturalQuotRem
+ , naturalSetBit
+ , naturalSetBit#
+ , naturalShiftL
+ , naturalShiftR
+ , naturalSignum
+ , naturalSqr
+ , naturalTestBit
+ , naturalToAddr
+ , naturalToAddr#
+ , naturalToBigNat#
+ , naturalToMutableByteArray#
+ , naturalToWord
+ , naturalToWordClamp
+ , naturalToWordClamp#
+ , naturalToWordMaybe#
+ , naturalZero
)
where
import GHC.Internal.Num
-import GHC.Num.Integer
-import GHC.Num.Natural
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11397,7 +11397,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -8569,7 +8569,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bd917d87b541147dc1eae2efc9bf47…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9bd917d87b541147dc1eae2efc9bf47…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Add support for building bytecode libraries
by Marge Bot (＠marge-bot) 04 Dec '25
by Marge Bot (＠marge-bot) 04 Dec '25
04 Dec '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cc71ce2d by Matthew Pickering at 2025-12-04T10:11:36-05:00
Add support for building bytecode libraries
A bytecode library is a collection of bytecode files (.gbc) and a
library which combines together additional object files.
A bytecode library is created by invoking GHC with the `-bytecodelib`
flag.
A library can be created from in-memory `ModuleByteCode` linkables or
by passing `.gbc` files as arguments on the command line.
Fixes #26298
- - - - -
06715c1f by Matthew Pickering at 2025-12-04T10:11:36-05:00
Load bytecode libraries to satisfy package dependencies
This commit allows you to use a bytecode library to satisfy a package
dependency when using the interpreter.
If a user enables `-fprefer-byte-code`, then if a package provides a
bytecode library, that will be loaded and used to satisfy the
dependency.
The main change is to separate the relevant parts of the `LoaderState`
into external and home package byte code. Bytecode is loaded into either
the home package or external part (similar to HPT/EPS split), HPT
bytecode can be unloaded. External bytecode is never unloaded.
The unload function has also only been called with an empty list of
"stable linkables" for a long time. It has been modified to directly
implement a complete unloading of the home package bytecode linkables.
At the moment, the bytecode libraries are found in the "library-dirs"
field from the package description. In the future when `Cabal`
implements support for "bytecode-library-dirs" field, we can read the
bytecode libraries from there. No changes to the Cabal submodule are
necessary at the moment.
Four new tests are added in testsuite/tests/cabal, which generate fake
package descriptions and test loading the libraries into GHCi.
Fixes #26298
- - - - -
8d862bf9 by mangoiv at 2025-12-04T10:11:47-05:00
ExplicitLevelImports: improve documentation of the code
- more explicit names for variable names like `flg` or `topLevel`
- don't pass the same value twice to functions
- some explanations of interesting but undocumented code paths
- adjust comment to not mention non-existent error message
- - - - -
58 changed files:
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session.hs
- + compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/State.hs
- compiler/ghc.cabal.in
- docs/users_guide/phases.rst
- libraries/ghc-boot/GHC/Unit/Database.hs
- testsuite/config/ghc
- testsuite/mk/boilerplate.mk
- + testsuite/tests/cabal/Bytecode.hs
- + testsuite/tests/cabal/BytecodeForeign.c
- + testsuite/tests/cabal/BytecodeForeign.hs
- testsuite/tests/cabal/Makefile
- testsuite/tests/cabal/all.T
- + testsuite/tests/cabal/bytecode.pkg
- + testsuite/tests/cabal/bytecode.script
- + testsuite/tests/cabal/bytecode_foreign.pkg
- + testsuite/tests/cabal/bytecode_foreign.script
- testsuite/tests/cabal/ghcpkg03.stderr
- testsuite/tests/cabal/ghcpkg03.stderr-mingw32
- testsuite/tests/cabal/ghcpkg05.stderr
- testsuite/tests/cabal/ghcpkg05.stderr-mingw32
- + testsuite/tests/cabal/pkg_bytecode.stderr
- + testsuite/tests/cabal/pkg_bytecode.stdout
- + testsuite/tests/cabal/pkg_bytecode_foreign.stderr
- + testsuite/tests/cabal/pkg_bytecode_foreign.stdout
- + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr
- + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout
- + testsuite/tests/cabal/pkg_bytecode_with_o.stderr
- + testsuite/tests/cabal/pkg_bytecode_with_o.stdout
- testsuite/tests/driver/bytecode-object/Makefile
- testsuite/tests/driver/bytecode-object/all.T
- testsuite/tests/driver/bytecode-object/bytecode_object19.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr
- + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout
- utils/ghc-pkg/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b6a2ee639cafbd83a13803e7afdf5e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b6a2ee639cafbd83a13803e7afdf5e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
04 Dec '25
Teo Camarasu pushed to branch wip/T26625 at Glasgow Haskell Compiler / GHC
Commits:
09bcbe2e by Teo Camarasu at 2025-12-04T12:13:47+00:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
5 changed files:
- libraries/base/src/GHC/Num.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/GHC/Num.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
@@ -16,11 +17,190 @@ module GHC.Num
( Num(..)
, subtract
, quotRemInteger
- , module GHC.Num.Integer
- , module GHC.Num.Natural
+ , integerFromNatural
+ , integerToNaturalClamp
+ , integerToNaturalThrow
+ , integerToNatural
+ , integerToWord#
+ , integerToInt#
+ , integerToWord64#
+ , integerToInt64#
+ , integerAdd
+ , integerMul
+ , integerSub
+ , integerNegate
+ , integerAbs
+ , integerPopCount#
+ , integerQuot
+ , integerRem
+ , integerDiv
+ , integerMod
+ , integerDivMod#
+ , integerQuotRem#
+ , integerEncodeFloat#
+ , integerEncodeDouble#
+ , integerGcd
+ , integerLcm
+ , integerAnd
+ , integerOr
+ , integerXor
+ , integerComplement
+ , integerBit#
+ , integerTestBit#
+ , integerShiftL#
+ , integerShiftR#
+ , integerFromWord#
+ , integerFromWord64#
+ , integerFromInt64#
+ , Integer(..)
+ , integerBit
+ , integerCheck
+ , integerCheck#
+ , integerCompare
+ , integerDecodeDouble#
+ , integerDivMod
+ , integerEncodeDouble
+ , integerEq
+ , integerEq#
+ , integerFromAddr
+ , integerFromAddr#
+ , integerFromBigNat#
+ , integerFromBigNatNeg#
+ , integerFromBigNatSign#
+ , integerFromByteArray
+ , integerFromByteArray#
+ , integerFromInt
+ , integerFromInt#
+ , integerFromWord
+ , integerFromWordList
+ , integerFromWordNeg#
+ , integerFromWordSign#
+ , integerGcde
+ , integerGcde#
+ , integerGe
+ , integerGe#
+ , integerGt
+ , integerGt#
+ , integerIsNegative
+ , integerIsNegative#
+ , integerIsOne
+ , integerIsPowerOf2#
+ , integerIsZero
+ , integerLe
+ , integerLe#
+ , integerLog2
+ , integerLog2#
+ , integerLogBase
+ , integerLogBase#
+ , integerLogBaseWord
+ , integerLogBaseWord#
+ , integerLt
+ , integerLt#
+ , integerNe
+ , integerNe#
+ , integerOne
+ , integerPowMod#
+ , integerQuotRem
+ , integerRecipMod#
+ , integerShiftL
+ , integerShiftR
+ , integerSignum
+ , integerSignum#
+ , integerSizeInBase#
+ , integerSqr
+ , integerTestBit
+ , integerToAddr
+ , integerToAddr#
+ , integerToBigNatClamp#
+ , integerToBigNatSign#
+ , integerToInt
+ , integerToMutableByteArray
+ , integerToMutableByteArray#
+ , integerToWord
+ , integerZero
+ , naturalToWord#
+ , naturalPopCount#
+ , naturalShiftR#
+ , naturalShiftL#
+ , naturalAdd
+ , naturalSub
+ , naturalSubThrow
+ , naturalSubUnsafe
+ , naturalMul
+ , naturalQuotRem#
+ , naturalQuot
+ , naturalRem
+ , naturalAnd
+ , naturalAndNot
+ , naturalOr
+ , naturalXor
+ , naturalTestBit#
+ , naturalBit#
+ , naturalGcd
+ , naturalLcm
+ , naturalLog2#
+ , naturalLogBaseWord#
+ , naturalLogBase#
+ , naturalPowMod
+ , naturalSizeInBase#
+ , Natural(..)
+ , naturalBit
+ , naturalCheck
+ , naturalCheck#
+ , naturalClearBit
+ , naturalClearBit#
+ , naturalCompare
+ , naturalComplementBit
+ , naturalComplementBit#
+ , naturalEncodeDouble#
+ , naturalEncodeFloat#
+ , naturalEq
+ , naturalEq#
+ , naturalFromAddr
+ , naturalFromAddr#
+ , naturalFromBigNat#
+ , naturalFromByteArray#
+ , naturalFromWord
+ , naturalFromWord#
+ , naturalFromWord2#
+ , naturalFromWordList
+ , naturalGe
+ , naturalGe#
+ , naturalGt
+ , naturalGt#
+ , naturalIsOne
+ , naturalIsPowerOf2#
+ , naturalIsZero
+ , naturalLe
+ , naturalLe#
+ , naturalLog2
+ , naturalLogBase
+ , naturalLogBaseWord
+ , naturalLt
+ , naturalLt#
+ , naturalNe
+ , naturalNe#
+ , naturalNegate
+ , naturalOne
+ , naturalPopCount
+ , naturalQuotRem
+ , naturalSetBit
+ , naturalSetBit#
+ , naturalShiftL
+ , naturalShiftR
+ , naturalSignum
+ , naturalSqr
+ , naturalTestBit
+ , naturalToAddr
+ , naturalToAddr#
+ , naturalToBigNat#
+ , naturalToMutableByteArray#
+ , naturalToWord
+ , naturalToWordClamp
+ , naturalToWordClamp#
+ , naturalToWordMaybe#
+ , naturalZero
)
where
import GHC.Internal.Num
-import GHC.Num.Integer
-import GHC.Num.Natural
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11397,7 +11397,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -8569,7 +8569,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/09bcbe2e0b4a65a2c173c9574e46b0f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/09bcbe2e0b4a65a2c173c9574e46b0f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] 7 commits: Don't call implicitRequirementsShallow
by Torsten Schmits (＠torsten.schmits) 04 Dec '25
by Torsten Schmits (＠torsten.schmits) 04 Dec '25
04 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
43fca822 by Matthew Pickering at 2025-12-04T11:57:58+01:00
Don't call implicitRequirementsShallow
- - - - -
cdedac3a by Ben Gamari at 2025-12-04T11:57:58+01:00
compiler: Fix CPP guards around ghc_unique_counter64
The `ghc_unique_counter64` symbol was introduced in the RTS in the
64-bit unique refactor (!10568) which has been backported to %9.6.7 and
%9.8.4. Update the CPP to reflect this.
Fixes #25576.
- - - - -
0e9217b9 by Matthew Pickering at 2025-12-04T11:57:58+01:00
Use ModuleGraph for cache
- - - - -
e09c09cc by Matthew Pickering at 2025-12-04T11:57:58+01:00
OsPath for Map
- - - - -
bb47dbf0 by Matthew Pickering at 2025-12-04T11:57:58+01:00
Set hpt deps
- - - - -
92f0dc46 by Matthew Pickering at 2025-12-04T11:57:58+01:00
HomeUnitMap
- - - - -
87ea8e10 by Matthew Pickering at 2025-12-04T11:58:41+01:00
Use a name provider map for home packages
- - - - -
11 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- compiler/cbits/genSym.c
- ghc/Main.hs
- testsuite/tests/ghc-api/downsweep/OldModLocation.hs
- testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -114,6 +114,8 @@ import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Data.OsPath (OsPath)
+import qualified GHC.Data.OsPath as OsPath
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
@@ -247,7 +249,7 @@ depanalPartial excluded_mods allow_dup_roots = do
liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
(errs, graph_nodes) <- liftIO $ downsweep
- hsc_env (mgModSummaries old_graph)
+ hsc_env (mgModSummaries old_graph) (Just old_graph)
excluded_mods allow_dup_roots
let
mod_graph = mkModuleGraph graph_nodes
@@ -1541,6 +1543,10 @@ warnUnnecessarySourceImports sccs = do
-- an import of this module mean.
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
+moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
+moduleGraphNodeMap graph =
+ M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]
+
-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis)
@@ -1559,6 +1565,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv
downsweep :: HscEnv
-> [ModSummary]
-- ^ Old summaries
+ -> Maybe ModuleGraph
+ -- ^ Existing module graph to reuse cached nodes from
-> [ModuleName] -- Ignore dependencies on these; treat
-- them as if they were package modules
-> Bool -- True <=> allow multiple targets to have
@@ -1568,10 +1576,10 @@ downsweep :: HscEnv
-- The non-error elements of the returned list all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true in
-- which case there can be repeats
-downsweep hsc_env old_summaries excl_mods allow_dup_roots = do
+downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do
n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
new <- rootSummariesParallel n_jobs hsc_env summary
- downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new
+ downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new
where
summary = getRootSummary excl_mods old_summary_map
@@ -1580,21 +1588,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do
-- file was used in.
-- Reuse these if we can because the most expensive part of downsweep is
-- reading the headers.
- old_summary_map :: M.Map (UnitId, FilePath) ModSummary
+ old_summary_map :: M.Map (UnitId, OsPath) ModSummary
old_summary_map =
- M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]
+ M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries]
downsweep_imports :: HscEnv
- -> M.Map (UnitId, FilePath) ModSummary
+ -> M.Map (UnitId, OsPath) ModSummary
+ -> Maybe ModuleGraph
-> [ModuleName]
-> Bool
-> ([(UnitId, DriverMessages)], [ModSummary])
-> IO ([DriverMessages], [ModuleGraphNode])
-downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk)
+downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk)
= do
let root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
- (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
+ let done0 = maybe M.empty moduleGraphNodeMap old_graph
+ (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map)
let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)
let unit_env = hsc_unit_env hsc_env
let tmpfs = hsc_tmpfs hsc_env
@@ -1725,7 +1735,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
getRootSummary ::
[ModuleName] ->
- M.Map (UnitId, FilePath) ModSummary ->
+ M.Map (UnitId, OsPath) ModSummary ->
HscEnv ->
Target ->
IO (Either (UnitId, DriverMessages) ModSummary)
@@ -2071,7 +2081,7 @@ mkRootMap summaries = Map.fromListWith (flip (++))
summariseFile
:: HscEnv
-> HomeUnit
- -> M.Map (UnitId, FilePath) ModSummary -- old summaries
+ -> M.Map (UnitId, OsPath) ModSummary -- old summaries
-> FilePath -- source file name
-> Maybe Phase -- start phase
-> Maybe (StringBuffer,UTCTime)
@@ -2080,7 +2090,7 @@ summariseFile
summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
-- we can use a cached summary if one is available and the
-- source file hasn't changed,
- | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries
+ | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
= do
let location = ms_location $ old_summary
@@ -2101,6 +2111,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
where
-- change the main active unit so all operations happen relative to the given unit
hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
+ src_fn_os = OsPath.unsafeEncodeUtf src_fn
-- src_fn does not necessarily exist on the filesystem, so we need to
-- check what kind of target we are dealing with
get_src_hash = case maybe_buf of
@@ -2190,7 +2201,7 @@ data SummariseResult =
summariseModule
:: HscEnv
-> HomeUnit
- -> M.Map (UnitId, FilePath) ModSummary
+ -> M.Map (UnitId, OsPath) ModSummary
-- ^ Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
@@ -2251,7 +2262,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
Right ms -> FoundHome ms
new_summary_cache_check loc mod src_fn h
- | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =
+ | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
-- check the hash on the source file, and
-- return the cached summary if it hasn't changed. If the
@@ -2262,6 +2273,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
Nothing ->
checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
| otherwise = new_summary loc mod src_fn h
+ where
+ src_fn_os = OsPath.unsafeEncodeUtf src_fn
new_summary :: ModLocation
-> Module
@@ -2330,7 +2343,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+-- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+ let implicit_sigs = []
return $
ModSummary
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -358,7 +358,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$>
let hsc' = hscSetActiveUnitId uid hsc_env
-- Load potential dependencies first
(done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)
- (homeUnitDepends (hsc_units hsc'))
+ (Set.toList (homeUnitDepends (hsc_units hsc')))
pls'' <- loadCmdLineLibs'' interp hsc' pls'
return $ (Set.insert uid done', pls'')
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -475,11 +475,14 @@ renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
-- not really correct as pkg_fs is unlikely to be a valid unit-id but
-- we will report the failure later...
where
- home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps
+ home_names =
+ [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))
+ | uid <- S.toList hpt_deps
+ ]
units = ue_units unit_env
- hpt_deps :: [UnitId]
+ hpt_deps :: S.Set UnitId
hpt_deps = homeUnitDepends units
hscRenameRawPkgQual ::
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -142,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid])
loop acc (uid:uids)
| uid `Set.member` acc = loop acc uids
| otherwise =
- let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))
+ let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)))
in loop (Set.insert uid acc) (hue ++ uids)
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -68,8 +68,9 @@ import Control.Monad
import Data.Time
import qualified Data.Map as M
import GHC.Driver.Env
- ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env), hscUnitIndexQuery )
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph) )
import GHC.Driver.Config.Finder
+import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap)
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -164,29 +165,35 @@ findImportedModule hsc_env mod pkg_qual =
fopts = initFinderOpts dflags
in do
query <- hscUnitIndexQuery hsc_env
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
-> UnitIndexQuery
+ -> ModuleNameHomeMap
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
- | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
+ | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
+ (complete_units, module_name_map) = home_module_map
+ module_home_units = M.findWithDefault Set.empty mod_name module_name_map
+ current_unit_id = homeUnitId <$> mhome_unit
all_opts = case mhome_unit of
- Nothing -> other_fopts
- Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
+ Nothing -> other_fopts_list
+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
+ other_fopts_map = M.fromList other_fopts_list
home_import = case mhome_unit of
Just home_unit -> findHomeModule fc fopts home_unit mod_name
@@ -197,7 +204,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -206,7 +213,7 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
-- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
-- that is not the same!! home_import is first because we need to look within ourselves
-- first before looking at the packages in order.
- any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
+ any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list)
pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
@@ -217,9 +224,21 @@ findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
units = case mhome_unit of
Nothing -> ue_units ue
Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
- hpt_deps :: [UnitId]
+ hpt_deps :: Set.Set UnitId
hpt_deps = homeUnitDepends units
- other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
+ dep_providers = Set.intersection module_home_units hpt_deps
+ known_other_uids =
+ let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
+ in Set.toList providers
+ unknown_units =
+ let candidates = Set.difference hpt_deps complete_units
+ excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
+ in Set.toList (Set.difference candidates excluded)
+ other_home_uids = known_other_uids ++ unknown_units
+ other_fopts_list =
+ [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
+ | uid <- other_home_uids
+ ]
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph
, mgModSummaries
, mgModSummaries'
, mgLookupModule
+ , ModuleNameHomeMap
+ , mgHomeModuleMap
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
@@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where
-- check that the module and its hs-boot agree.
--
-- The graph is not necessarily stored in topologically-sorted order. Use
+type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId))
+
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-- A cached transitive dependency calculation so that a lot of work is not
-- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
+ , mg_home_map :: ModuleNameHomeMap
+ -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete.
}
-- | Map a function 'f' over all the 'ModSummaries'.
-- To preserve invariants 'f' can't change the isBoot status.
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG f mg@ModuleGraph{..} = mg
- { mg_mss = flip fmap mg_mss $ \case
- InstantiationNode uid iuid -> InstantiationNode uid iuid
- LinkNode uid nks -> LinkNode uid nks
- ModuleNode deps ms -> ModuleNode deps (f ms)
+ { mg_mss = new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
+ where
+ new_mss =
+ flip fmap mg_mss $ \case
+ InstantiationNode uid iuid -> InstantiationNode uid iuid
+ LinkNode uid nks -> LinkNode uid nks
+ ModuleNode deps ms -> ModuleNode deps (f ms)
unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
unionMG a b =
@@ -177,11 +187,27 @@ unionMG a b =
in ModuleGraph {
mg_mss = new_mss
, mg_graph = mkTransDeps new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
+mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
+mkHomeModuleMap nodes =
+ (complete_units, provider_map)
+ where
+ provider_map =
+ Map.fromListWith Set.union
+ [ (ms_mod_name ms, Set.singleton (ms_unitid ms))
+ | ModuleNode _ ms <- nodes
+ ]
+ complete_units =
+ Set.fromList
+ [ ms_unitid ms
+ | ModuleNode _ ms <- nodes
+ ]
+
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
@@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
= Just ms
go _ = Nothing
+mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
+mgHomeModuleMap = mg_home_map
+
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty)
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
@@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms =
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
extendMG ModuleGraph{..} deps ms = ModuleGraph
- { mg_mss = ModuleNode deps ms : mg_mss
- , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss)
+ { mg_mss = new_mss
+ , mg_graph = mkTransDeps new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
+ where
+ new_mss = ModuleNode deps ms : mg_mss
extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
extendMGInst mg uid depUnitId = mg
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -469,7 +469,7 @@ data UnitState = UnitState {
-- -Wunused-packages warning.
explicitUnits :: [(Unit, Maybe PackageArg)],
- homeUnitDepends :: [UnitId],
+ homeUnitDepends :: Set UnitId,
-- | This is a full map from 'ModuleName' to all modules which may possibly
-- be providing it. These providers may be hidden (but we'll still want
@@ -504,7 +504,7 @@ emptyUnitState = UnitState {
unwireMap = emptyUniqMap,
preloadUnits = [],
explicitUnits = [],
- homeUnitDepends = [],
+ homeUnitDepends = Set.empty,
moduleNameProvidersMap = emptyUniqMap,
pluginModuleNameProvidersMap = emptyUniqMap,
requirementContext = emptyUniqMap,
@@ -1573,7 +1573,7 @@ mkUnitState logger cfg index = do
let !state = UnitState
{ preloadUnits = dep_preload
, explicitUnits = explicit_pkgs
- , homeUnitDepends = Set.toList home_unit_deps
+ , homeUnitDepends = home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
, moduleNameProvidersMap
=====================================
compiler/cbits/genSym.c
=====================================
@@ -9,7 +9,19 @@
//
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+
+#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+// Unique64 patch was present in 9.10 and later
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)
+// Unique64 patch was backported to 9.8.4
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)
+// Unique64 patch was backported to 9.6.7
+#define HAVE_UNIQUE64 1
+#endif
+
+#if !defined(HAVE_UNIQUE64)
HsWord64 ghc_unique_counter64 = 0;
#endif
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
=====================================
ghc/Main.hs
=====================================
@@ -893,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc ()
checkUnitCycles dflags graph = processSCCs sccs
where
mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId
- mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))
+ mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue)))
nodes = map mkNode (unitEnv_elts graph)
sccs = stronglyConnCompFromEdgedVerticesOrd nodes
=====================================
testsuite/tests/ghc-api/downsweep/OldModLocation.hs
=====================================
@@ -47,13 +47,13 @@ main = do
liftIO $ do
- _emss <- downsweep hsc_env [] [] False
+ _emss <- downsweep hsc_env [] Nothing [] False
flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
createDirectoryIfMissing False "mydir"
renameFile "B.hs" "mydir/B.hs"
- (_, nodes) <- downsweep hsc_env [] [] False
+ (_, nodes) <- downsweep hsc_env [] Nothing [] False
-- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with
-- (ms_location old_summary) like summariseFile used to instead of
=====================================
testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
=====================================
@@ -168,7 +168,7 @@ go label mods cnd =
setTargets [tgt]
hsc_env <- getSession
- (_, nodes) <- liftIO $ downsweep hsc_env [] [] False
+ (_, nodes) <- liftIO $ downsweep hsc_env [] Nothing [] False
it label $ cnd (mapMaybe moduleGraphNodeModSum nodes)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0278068c97035849574b938acbde7d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0278068c97035849574b938acbde7d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0