05 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) 05 Dec '25
by Marge Bot (＠marge-bot) 05 Dec '25
05 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
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Renamer: reinstate the template haskell level check in notFound
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:
3bd7dd44 by mangoiv at 2025-12-04T04:36:45-05:00
Renamer: reinstate the template haskell level check in notFound
Out-of-scope names might be caused by a staging error, as is explained by
Note [Out of scope might be a staging error] in GHC.Tc.Utils.Env.hs.
This logic was assumed to be dead code after 217caad1 and has thus been
removed. This commit reintroduces it and thus fixes issue #26099.
- - - - -
0318010b by Zubin Duggal at 2025-12-04T04:37:27-05:00
testlib: Optionally include the way name in the expected output file
This allows us to have different outputs for different ways.
- - - - -
6d945fdd by Zubin Duggal at 2025-12-04T04:37:27-05:00
testsuite: Accept output of tests failing in ext-interp way due to differing compilation requirements
Fixes #26552
- - - - -
0ffc5243 by Cheng Shao at 2025-12-04T04:38:09-05:00
devx: minor fixes for compile_flags.txt
This patch includes minor fixes for compile_flags.txt to improve
developer experience when using clangd as language server to hack on
RTS C sources:
- Ensure `-fPIC` is passed and `__PIC__` is defined, to be coherent
with `-DDYNAMIC` and ensure the `__PIC__` guarded code paths are
indexed
- Add the missing `-DRtsWay` definition, otherwise a few source files
like `RtsUtils.c` and `Trace.c` would produce clangd errors
- - - - -
de728aab by Cheng Shao at 2025-12-04T05:11:01-05:00
rts: workaround -Werror=maybe-uninitialized false positives
In some cases gcc might report -Werror=maybe-uninitialized that we
know are false positives, but need to workaround it to make validate
builds with -Werror pass.
- - - - -
4a8fb42a by Cheng Shao at 2025-12-04T05:11:01-05:00
hadrian: use -Og as C/C++ optimization level when debugging
This commit enables -Og as optimization level when compiling the debug
ways of rts. According to gcc documentation
(https://gcc.gnu.org/onlinedocs/gcc/Optimize-Options.html#index-Og)
-Og is a better choice than -O0 for producing debuggable code. It's
also supported by clang as well, so it makes sense to use it as a
default for debugging. Also add missing -g3 flag to C++ compilation
flags in +debug_info flavour transformer.
- - - - -
b6a2ee63 by mangoiv at 2025-12-04T05:11:07-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
- - - - -
19 changed files:
- compile_flags.txt
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Env.hs
- hadrian/src/Flavour.hs
- hadrian/src/Settings/Packages.hs
- rts/linker/InitFini.c
- rts/sm/Sanity.c
- testsuite/driver/testlib.py
- + testsuite/tests/driver/T20696/T20696.stderr-ext-interp
- testsuite/tests/driver/T20696/all.T
- testsuite/tests/driver/fat-iface/all.T
- + testsuite/tests/driver/fat-iface/fat012.stderr-ext-interp
- + testsuite/tests/driver/fat-iface/fat015.stderr-ext-interp
- + testsuite/tests/splice-imports/SI07.stderr-ext-interp
- testsuite/tests/splice-imports/all.T
- + testsuite/tests/th/T26099.hs
- + testsuite/tests/th/T26099.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
compile_flags.txt
=====================================
@@ -1,3 +1,6 @@
+-fPIC
+-U__PIC__
+-D__PIC__
-Wimplicit
-include
rts/include/ghcversion.h
@@ -27,3 +30,4 @@ rts/include/ghcversion.h
-DDEBUG
-DDYNAMIC
-DPROFILING
+-DRtsWay="rts_thr_debug_p_dyn"
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -182,12 +182,12 @@ rnUntypedBracket e br_body
}
rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
-rn_utbracket (VarBr _ flg rdr_name)
- = do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name)
+rn_utbracket (VarBr _ is_value_name rdr_name)
+ = do { name <- lookupOccRn (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name)
; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name)
- ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name
- ; check_namespace flg name
- ; return (VarBr noExtField flg (noLocA name), unitFV name) }
+ ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName name
+ ; check_namespace is_value_name name
+ ; return (VarBr noExtField is_value_name (noLocA name), unitFV name) }
rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr noExtField e', fvs) }
@@ -919,8 +919,7 @@ checkThLocalTyName name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_lvl) ->
- do { let use_lvl_idx = thLevelIndex use_lvl
- -- We don't check the well levelledness of name here.
+ do -- We don't check the well levelledness of name here.
-- this would break test for #20969
--
-- Consequently there is no check&restiction for top level splices.
@@ -929,11 +928,11 @@ checkThLocalTyName name
-- Therefore checkCrossLevelLiftingTy shouldn't assume anything
-- about bind_lvl and use_lvl relation.
--
- ; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl
+ { traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl
<+> ppr use_lvl
<+> ppr use_lvl)
; dflags <- getDynFlags
- ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } }
+ ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl name } } }
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, attempt to fix it by using
@@ -947,15 +946,18 @@ checkThLocalNameWithLift = checkThLocalName True
checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
checkThLocalNameNoLift name = checkThLocalName False name >> return ()
--- | Implemenation of the level checks
+-- | Implementation of the level checks
-- See Note [Template Haskell levels]
checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn)
checkThLocalName allow_lifting name_var
-- Exact and Orig names are not imported, so presumed available at all levels.
+ -- whenever the user uses exact names, e.g. say @'mkNameG_v' "" "Foo" "bar"@,
+ -- even though the 'mkNameG_v' here is essentially a quotation, we do not do
+ -- level checks as we assume that the user was trying to bypass the level checks
| isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var))
= return (HsVar noExtField name_var)
- | isUnboundName name -- Do not report two errors for
- = return (HsVar noExtField name_var) -- $(not_in_scope args)
+ | isUnboundName name -- Do not report two errors for
+ = return (HsVar noExtField name_var) -- $(not_in_scope args)
| isWiredInName name
= return (HsVar noExtField name_var)
| otherwise
@@ -964,16 +966,15 @@ checkThLocalName allow_lifting name_var
; case mb_local_use of {
Nothing -> return (HsVar noExtField name_var) ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_lvl) ->
- do { let use_lvl_idx = thLevelIndex use_lvl
- ; cur_mod <- extractModule <$> getGblEnv
+ do { cur_mod <- extractModule <$> getGblEnv
; let is_local
| Just mod <- nameModule_maybe name = mod == cur_mod
| otherwise = True
- ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl)
+ ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl)
; dflags <- getDynFlags
; env <- getGlobalRdrEnv
; let mgre = lookupGRE_Name env name
- ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } }
+ ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } }
where
name = getName name_var
@@ -981,14 +982,21 @@ checkThLocalName allow_lifting name_var
checkCrossLevelLifting :: DynFlags
-> LevelCheckReason
-> TopLevelFlag
+ -- ^ whether or not the identifier is a top level identifier
-> Bool
+ -- ^ the name of the current module is the name of the module
+ -- of the name that we're examining (if it exists)
-> Bool
+ -- ^ whether or not the compiler is allowed to insert
+ -- 'lift' to fix a potential staging error
-> Set.Set ThLevelIndex
+ -- ^ the levels at which the identifier is bound
-> ThLevel
- -> ThLevelIndex
+ -- ^ the level that the identifier is being used at
-> LIdOccP GhcRn
+ -- ^ the identifier that is being checked
-> TcM (HsExpr GhcRn)
-checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var
+checkCrossLevelLifting dflags reason top_lvl_flg is_local allow_lifting bind_lvl use_lvl name_var
-- 1. If name is in-scope, at the correct level.
| use_lvl_idx `Set.member` bind_lvl = return (HsVar noExtField name_var)
-- 2. Name is imported with -XImplicitStagePersistence
@@ -996,11 +1004,12 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use
, xopt LangExt.ImplicitStagePersistence dflags = return (HsVar noExtField name_var)
-- 3. Name is top-level, with -XImplicitStagePersistence, and needs
-- to be persisted into the future.
- | isTopLevel top_lvl
+ | isTopLevel top_lvl_flg
, is_local
, any (use_lvl_idx >=) (Set.toList bind_lvl)
, xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name) >> return (HsVar noExtField name_var)
-- 4. Name is in a bracket, and lifting is allowed
+ -- We need to increment at most once because nested brackets are not allowed
| Brack _ pending <- use_lvl
, any (\bind_idx -> use_lvl_idx == incThLevelIndex bind_idx) (Set.toList bind_lvl)
, allow_lifting
@@ -1020,10 +1029,11 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use
| otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag ) >> return (HsVar noExtField name_var)
where
name = getName name_var
+ use_lvl_idx = thLevelIndex use_lvl
-checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM ()
-checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name
- | isTopLevel top_lvl
+checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> Name -> TcM ()
+checkCrossLevelLiftingTy dflags top_lvl_flg bind_lvl use_lvl name
+ | isTopLevel top_lvl_flg
, xopt LangExt.ImplicitStagePersistence dflags
= return ()
@@ -1038,6 +1048,8 @@ checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name
| otherwise
= return ()
+ where
+ use_lvl_idx = thLevelIndex use_lvl
{-
Note [Keeping things alive for Template Haskell]
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1683,17 +1683,15 @@ which is defined at the top-level and therefore fails with an error that we have
the stage restriction.
```
-Main.hs:12:14: error:
- • GHC stage restriction:
- instance for ‘Show
- (T ())’ is used in a top-level splice, quasi-quote, or annotation,
- and must be imported, not defined locally
+Main.hs:10:14: error: [GHC-28914]
+ • Level error: instance for ‘Show (T ())’ is bound at level 0
+ but used at level -1
• In the expression: foo [|| T () ||]
- In the Template Haskell splice $$(foo [|| T () ||])
+ In the typed Template Haskell splice: $$(foo [|| T () ||])
In the expression: $$(foo [|| T () ||])
|
-12 | let x = $$(foo [|| T () ||])
- |
+10 | let x = $$(foo [|| T () ||])
+ | ^^^
```
Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -8,6 +8,7 @@
-- in module Language.Haskell.Syntax.Extension
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Utils.Env(
TyThing(..), TcTyThing(..), TcId,
@@ -1213,6 +1214,20 @@ pprBinders bndrs = pprWithCommas ppr bndrs
notFound :: Name -> TcM TyThing
notFound name
= do { lcl_env <- getLclEnv
+ ; lvls <- getCurrentAndBindLevel name
+ ; if -- See Note [Out of scope might be a staging error]
+ | isUnboundName name -> failM -- If the name really isn't in scope
+ -- don't report it again (#11941)
+ -- the
+ -- the 'Nothing' case of 'getCurrentAndBindLevel'
+ -- currently means 'isUnboundName' but to avoid
+ -- introducing bugs after a refactoring of that
+ -- function, we check this completely independently
+ -- before scrutinizing lvls
+ | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls
+ -> failWithTc (TcRnBadlyLevelled (LevelCheckSplice name Nothing) bind_lvls (thLevelIndex lvl) Nothing ErrorWithoutFlag)
+ | otherwise -> pure ()
+
; if isTermVarOrFieldNameSpace (nameNameSpace name)
then
-- This code path is only reachable with RequiredTypeArguments enabled
@@ -1243,14 +1258,23 @@ wrongThingErr expected thing name =
{- Note [Out of scope might be a staging error]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
- x = 3
- data T = MkT $(foo x)
+ type T = Int
+ foo = $(1 :: T)
+
+GHC currently leaves the user some liberty when it comes to using
+types in a manner that is theoretically not well-staged.
+E.g. if `T` here were to be a value, we would reject the program with
+a staging error. Since it is a type though, we allow it for backwards
+compatibility reasons.
+
+However, in this case, we're just in the process of renaming a splice
+when trying to type check an expression involving a type, that hasn't
+even been added to the (type checking) environment yet. That is, why
+it is out of scope.
-where 'foo' is imported from somewhere.
+The reason why we cannot recognise this issue earlier is, that if we
+are not actually type checking the splice, i.e. if we're only using the
+name of the type (e.g. ''T), the program should be accepted.
-This is really a staging error, because we can't run code involving 'x'.
-But in fact the type checker processes types first, so 'x' won't even be
-in the type envt when we look for it in $(foo x). So inside splices we
-report something missing from the type env as a staging error.
-See #5752 and #5795.
+We stop and report a staging error.
-}
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -166,6 +166,7 @@ enableDebugInfo :: Flavour -> Flavour
enableDebugInfo = addArgs $ notStage0 ? mconcat
[ builder (Ghc CompileHs) ? pure ["-g3"]
, builder (Ghc CompileCWithGhc) ? pure ["-optc-g3"]
+ , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3"]
, builder (Cc CompileC) ? arg "-g3"
, builder (Cabal Setup) ? arg "--disable-library-stripping"
, builder (Cabal Setup) ? arg "--disable-executable-stripping"
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -351,7 +351,7 @@ rtsPackageArgs = package rts ? do
, Debug `wayUnit` way ? pure [ "-DDEBUG"
, "-fno-omit-frame-pointer"
, "-g3"
- , "-O0" ]
+ , "-Og" ]
-- Set the namespace for the rts fs functions
, arg $ "-DFS_NAMESPACE=rts"
=====================================
rts/linker/InitFini.c
=====================================
@@ -75,7 +75,7 @@ static void sortInitFiniList(struct InitFiniList **slist, enum SortOrder order)
while (*last != NULL && (*last)->next != NULL) {
struct InitFiniList *s0 = *last;
struct InitFiniList *s1 = s0->next;
- bool flip;
+ bool flip = false;
switch (order) {
case INCREASING: flip = s0->priority > s1->priority; break;
case DECREASING: flip = s0->priority < s1->priority; break;
=====================================
rts/sm/Sanity.c
=====================================
@@ -692,7 +692,7 @@ checkCompactObjects(bdescr *bd)
ASSERT((W_)str == (W_)block + sizeof(StgCompactNFDataBlock));
StgWord totalW = 0;
- StgCompactNFDataBlock *last;
+ StgCompactNFDataBlock *last = block;
for ( ; block ; block = block->next) {
last = block;
ASSERT(block->owner == str);
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1971,7 +1971,7 @@ async def do_compile(name: TestName,
# of whether we expected the compilation to fail or not (successful
# compilations may generate warnings).
- expected_stderr_file = find_expected_file(name, 'stderr')
+ expected_stderr_file = find_expected_file(name, 'stderr', way)
actual_stderr_file = add_suffix(name, 'comp.stderr')
diff_file_name = in_testdir(add_suffix(name, 'comp.diff'))
@@ -2012,7 +2012,7 @@ async def compile_cmp_asm(name: TestName,
# of whether we expected the compilation to fail or not (successful
# compilations may generate warnings).
- expected_asm_file = find_expected_file(name, 'asm')
+ expected_asm_file = find_expected_file(name, 'asm', way)
actual_asm_file = add_suffix(name, 's')
if not await compare_outputs(way, 'asm',
@@ -2036,7 +2036,7 @@ async def compile_grep_asm(name: TestName,
if badResult(result):
return result
- expected_pat_file = find_expected_file(name, 'asm')
+ expected_pat_file = find_expected_file(name, 'asm', way)
actual_asm_file = add_suffix(name, 's')
if not grep_output(join_normalisers(normalise_errmsg),
@@ -2058,7 +2058,7 @@ async def compile_grep_core(name: TestName,
if badResult(result):
return result
- expected_pat_file = find_expected_file(name, 'substr-simpl')
+ expected_pat_file = find_expected_file(name, 'substr-simpl', way)
actual_core_file = add_suffix(name, 'dump-simpl')
if not grep_output(join_normalisers(normalise_errmsg),
@@ -2097,7 +2097,7 @@ async def compile_and_run__(name: TestName,
return result
if compile_stderr:
- expected_stderr_file = find_expected_file(name, 'ghc.stderr')
+ expected_stderr_file = find_expected_file(name, 'ghc.stderr', way)
actual_stderr_file = add_suffix(name, 'comp.stderr')
diff_file_name = in_testdir(add_suffix(name, 'comp.diff'))
@@ -2556,7 +2556,7 @@ def get_compiler_flags() -> List[str]:
async def stdout_ok(name: TestName, way: WayName) -> bool:
actual_stdout_file = add_suffix(name, 'run.stdout')
- expected_stdout_file = find_expected_file(name, 'stdout')
+ expected_stdout_file = find_expected_file(name, 'stdout', way)
extra_norm = join_normalisers(normalise_output, getTestOpts().extra_normaliser)
@@ -2583,7 +2583,7 @@ def dump_stdout( name: TestName ) -> None:
async def stderr_ok(name: TestName, way: WayName) -> bool:
actual_stderr_file = add_suffix(name, 'run.stderr')
- expected_stderr_file = find_expected_file(name, 'stderr')
+ expected_stderr_file = find_expected_file(name, 'stderr', way)
return await compare_outputs(way, 'stderr',
join_normalisers(normalise_errmsg, getTestOpts().extra_errmsg_normaliser), \
@@ -2688,7 +2688,7 @@ async def check_hp_ok(name: TestName) -> bool:
return False
async def check_prof_ok(name: TestName, way: WayName) -> bool:
- expected_prof_file = find_expected_file(name, 'prof.sample')
+ expected_prof_file = find_expected_file(name, 'prof.sample', way)
expected_prof_path = in_testdir(expected_prof_file)
# Check actual prof file only if we have an expected prof file to
@@ -3368,18 +3368,19 @@ def in_statsdir(name: Union[Path, str], suffix: str='') -> Path:
# Finding the sample output. The filename is of the form
#
-# <test>.stdout[-ws-<wordsize>][-<platform>|-<os>]
+# <test>.stdout[-ws-<wordsize>][-<platform>|-<os>][-<way>]
#
-def find_expected_file(name: TestName, suff: str) -> Path:
+def find_expected_file(name: TestName, suff: str, way: WayName) -> Path:
basename = add_suffix(name, suff)
# Override the basename if the user has specified one, this will then be
# subjected to the same name mangling scheme as normal to allow platform
# specific overrides to work.
basename = getTestOpts().use_specs.get(suff, basename)
- files = [str(basename) + ws + plat
+ files = [str(basename) + ws + plat + way_ext
for plat in ['-' + config.platform, '-' + config.os, '']
- for ws in ['-ws-' + config.wordsize, '']]
+ for ws in ['-ws-' + config.wordsize, '']
+ for way_ext in ['-' + way, '']]
for f in files:
if in_srcdir(f).exists():
=====================================
testsuite/tests/driver/T20696/T20696.stderr-ext-interp
=====================================
@@ -0,0 +1,3 @@
+[1 of 3] Compiling C ( C.hs, C.o )
+[2 of 3] Compiling B ( B.hs, B.o )
+[3 of 3] Compiling A ( A.hs, A.o )
=====================================
testsuite/tests/driver/T20696/all.T
=====================================
@@ -1,5 +1,4 @@
test('T20696', [extra_files(['A.hs', 'B.hs', 'C.hs'])
- , expect_broken_for(26552, ['ext-interp'])
, unless(ghc_dynamic(), skip)], multimod_compile, ['A', ''])
test('T20696-static', [extra_files(['A.hs', 'B.hs', 'C.hs'])
, when(ghc_dynamic(), skip)], multimod_compile, ['A', ''])
=====================================
testsuite/tests/driver/fat-iface/all.T
=====================================
@@ -9,12 +9,12 @@ test('fat010', [req_th,extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files],
# Check linking works when using -fbyte-code-and-object-code
test('fat011', [req_th, extra_files(['FatMain.hs', 'FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatMain', '-fbyte-code-and-object-code -fprefer-byte-code'])
# Check that we use interpreter rather than enable dynamic-too if needed for TH
-test('fat012', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code'])
+test('fat012', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code'])
# Check that no objects are generated if using -fno-code and -fprefer-byte-code
test('fat013', [req_th, req_bco, extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code'])
# When using interpreter should not produce objects
test('fat014', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script'])
-test('fat015', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
+test('fat015', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
test('T22807', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807A.hs', 'T22807B.hs'])]
, makefile_test, ['T22807'])
test('T22807_ghci', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807_ghci.hs'])]
=====================================
testsuite/tests/driver/fat-iface/fat012.stderr-ext-interp
=====================================
@@ -0,0 +1,2 @@
+[1 of 2] Compiling FatQuote ( FatQuote.hs, FatQuote.o )
+[2 of 2] Compiling FatTH ( FatTH.hs, FatTH.o )
=====================================
testsuite/tests/driver/fat-iface/fat015.stderr-ext-interp
=====================================
@@ -0,0 +1,6 @@
+[1 of 6] Compiling FatQuote ( FatQuote.hs, FatQuote.o, interpreted )
+[2 of 6] Compiling FatQuote1 ( FatQuote1.hs, interpreted )
+[3 of 6] Compiling FatQuote2 ( FatQuote2.hs, FatQuote2.o )
+[4 of 6] Compiling FatTH1 ( FatTH1.hs, nothing )
+[5 of 6] Compiling FatTH2 ( FatTH2.hs, nothing )
+[6 of 6] Compiling FatTHTop ( FatTHTop.hs, nothing )
=====================================
testsuite/tests/splice-imports/SI07.stderr-ext-interp
=====================================
@@ -0,0 +1,3 @@
+[1 of 3] Compiling SI05A ( SI05A.hs, SI05A.o )
+[2 of 3] Compiling SI07A ( SI07A.hs, nothing )
+[3 of 3] Compiling SI07 ( SI07.hs, nothing )
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -9,7 +9,7 @@ test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0']
test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0'])
test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0'])
test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0'])
-test('SI07', [expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
+test('SI07', [unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
# Instance tests
test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0'])
test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0'])
=====================================
testsuite/tests/th/T26099.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module M where
+
+type T = Int
+
+a = $(3 :: T)
=====================================
testsuite/tests/th/T26099.stderr
=====================================
@@ -0,0 +1,6 @@
+T26099.hs:6:12: error: [GHC-28914]
+ • Level error: ‘T’ is bound at level 0 but used at level -1
+ • In an expression type signature: T
+ In the expression: 3 :: T
+ In the untyped splice: $(3 :: T)
+
=====================================
testsuite/tests/th/all.T
=====================================
@@ -642,3 +642,4 @@ test('QQInQuote', normal, compile, [''])
test('QQTopError', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('GadtConSigs_th_pprint1', normal, compile, [''])
test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T26099', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/420913f9ff12d6a3e1a0f75ac18deb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/420913f9ff12d6a3e1a0f75ac18deb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0