- ghc-commits - Haskell.org

[Git][ghc/ghc][master] Discard type arguments in tcPatToExpr (#27440, #27583)
by Marge Bot (＠marge-bot) 07 Aug '26

07 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4f985108 by Vladislav Zavialov at 2026-08-07T17:49:50-04:00 Discard type arguments in tcPatToExpr (#27440, #27583) The builder expression of an implicitly bidirectional pattern synonym must not mention types written in the RHS: * Invisible type arguments led to a panic (#27440) * Required type arguments failed with out-of-scope variables (#27583) Both are now discarded, following the precedent established by pattern signatures (#9867). Discarding type arguments takes some care: a type pattern cannot be told from a value pattern by syntax alone, as the `type` keyword may be omitted. Consider: data T a b c where MkT :: forall a. forall b c -> a -> T a b c pattern P :: x -> T x y z pattern P x = MkT @a (type b) c x In P's right-hand side, `@a` and `type b` are clearly type arguments, but what about `c` and `x`? We can only tell by matching the patterns against MkT's type. So tcPatToExpr now runs in TcM and matches the arguments against the constructor's TyVarBinders using zipPatsBndrs, which is made public for this purpose. The resulting builder is $bP x = MkT _ _ x. See Note [Discarding types in the builder expression]. Test cases: T27440a T27440b T27440c T27440d T27440e T27583a T27583b T27583c T27583d T27583e T27583f T27583g Metric Increase: LinkableUsage02 Metric Decrease: T27336 Assisted-by: Claude Opus 5 - - - - - 23 changed files: - + changelog.d/T27440 - + changelog.d/T27583 - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - + testsuite/tests/patsyn/should_compile/T27440a.hs - + testsuite/tests/patsyn/should_compile/T27440b.hs - + testsuite/tests/patsyn/should_compile/T27440c.hs - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T27440d.hs - + testsuite/tests/patsyn/should_fail/T27440d.stderr - testsuite/tests/patsyn/should_fail/all.T - + testsuite/tests/vdq-rta/should_compile/T27583a.hs - + testsuite/tests/vdq-rta/should_compile/T27583b.hs - + testsuite/tests/vdq-rta/should_compile/T27583c.hs - + testsuite/tests/vdq-rta/should_compile/T27583d.hs - + testsuite/tests/vdq-rta/should_compile/T27583e.hs - + testsuite/tests/vdq-rta/should_compile/T27583g.hs - testsuite/tests/vdq-rta/should_compile/all.T - + testsuite/tests/vdq-rta/should_fail/T27440e.hs - + testsuite/tests/vdq-rta/should_fail/T27440e.stderr - + testsuite/tests/vdq-rta/should_fail/T27583f.hs - + testsuite/tests/vdq-rta/should_fail/T27583f.stderr - testsuite/tests/vdq-rta/should_fail/all.T Changes: ===================================== changelog.d/T27440 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27440 +mrs: !16434 +synopsis: + Fix a panic on ``@ty`` in a pattern synonym RHS +description: + An invisible type argument (``@ty``) in the right-hand side of an implicitly + bidirectional pattern synonym no longer causes a panic. ===================================== changelog.d/T27583 ===================================== @@ -0,0 +1,9 @@ +section: compiler +issues: #27583 +mrs: !16434 +synopsis: + Fix spurious out-of-scope errors from ``type ty`` in a pattern synonym RHS +description: + A required type argument with an explicit namespace specifier (``type ty``) + in the right-hand side of an implicitly bidirectional pattern synonym no + longer reports variables bound by the pattern as out of scope. ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -16,6 +16,7 @@ module GHC.Tc.Gen.Pat , tcCheckPat, tcCheckPat_O, tcInferPat , tcMatchPats , addDataConStupidTheta + , zipPatsBndrs ) where @@ -1727,7 +1728,7 @@ split_con_ty_args :: LexicalFixity -- How to wrap value arguments , [(HsTyPat GhcRn, TyVar)] -- Existentials , HsConPatDetails GhcRn ) -- Value arguments split_con_ty_args fixity con_like arg_pats = do - (bndr_ty_arg_prs, value_args) <- zip_pats_bndrs arg_pats (conLikeUserTyVarBinders con_like) + (bndr_ty_arg_prs, value_args) <- zipPatsBndrs arg_pats (conLikeUserTyVarBinders con_like) return $ if null ex_tvs -- Short cut common case then (bndr_ty_arg_prs, [], mk_details fixity value_args) else let (ex_prs, univ_prs) = partition is_existential bndr_ty_arg_prs @@ -1743,24 +1744,75 @@ split_con_ty_args fixity con_like arg_pats = do -- InfixCon becomes PrefixCon if there are fewer than 2 value arguments. -- Test case: T25127_infix -zip_pats_bndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn]) -zip_pats_bndrs (L loc pat : pats) (Bndr tv vis : tvbs) +-- | Line the arguments of a 'ConPat' up against the 'TyVarBinder's of its +-- 'ConLike', returning the type arguments with the binders they instantiate, +-- and the remaining value arguments. +-- +-- See Note [Zipping ConPat arguments with TyVarBinders] +-- +-- Precondition: 'check_con_pat_arity' has passed for these arguments, so that +-- we never run out of patterns while a required binder remains. +zipPatsBndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn]) +zipPatsBndrs (L loc pat : pats) (Bndr tv vis : tvbs) | isVisibleForAllTyFlag vis = do { tp <- setSrcSpanA loc $ pat_to_type_pat pat - ; (prs, pats') <- zip_pats_bndrs pats tvbs + ; (prs, pats') <- zipPatsBndrs pats tvbs ; return ((tp, tv) : prs, pats') } | InvisPat pat_spec tp <- pat , Invisible spec <- vis , pat_spec == spec - = do { (prs, pats') <- zip_pats_bndrs pats tvbs + = do { (prs, pats') <- zipPatsBndrs pats tvbs ; return ((tp, tv):prs, pats') } -zip_pats_bndrs pats (Bndr _ vis : tvbs) - -- zip_pats_bndrs [] (Bndr _ Required : tvbs) +zipPatsBndrs pats (Bndr _ vis : tvbs) + -- zipPatsBndrs [] (Bndr _ Required : tvbs) -- is ruled out by the arity check in splitConTyArgs, -- so we can assume (isInvisibleForAllTyFlag vis) = do { massert (isInvisibleForAllTyFlag vis) - ; zip_pats_bndrs pats tvbs } -zip_pats_bndrs pats [] = return ([], pats) + ; zipPatsBndrs pats tvbs } +zipPatsBndrs pats [] = return ([], pats) + +{- Note [Zipping ConPat arguments with TyVarBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The zipPatsBndrs function allows us to line up the arguments of a constructor +pattern `MkT p1 p2 ... pn` with the TyVarBinders of MkT's type. Consider + + MkT :: forall a b. forall c d -> a -> T a b c d + +Then, in a pattern match `MkT @s (type t) p q`, we have the following +correspondence: + + * pattern `@s` with the TyVarBinder `forall a.` + * no pattern with the TyVarBinder `forall b.` + * pattern `type t` with the TyVarBinder `forall c ->` + * pattern `p` with the TyVarBinder `forall d ->` + * pattern `q` is the one remaining value argument + +Note how `p` and `q` are exactly alike, and only the TyVarBinder can tell us +that `p` is a required type argument rather than a value argument. + +So the call (zipPatsBndrs pats tvbs) with the inputs + + pats = [@s, type t, p, q] + tvbs = [Bndr a Spec, Bndr b Spec, Bndr c Req, Bndr d Req] + +produces the following (ty_pats, val_pats) outputs: + + ty_pats = [(s, a), (t, c), (p, d)] + val_pats = [q] -- remaining value arguments + +Note that the ty_pats components are stripped: the type patterns have lost the +`@` or the `type` herald, and the binders have been reduced to their TyVars. + +This is currently used in two ways: + +1. In tcDataConPat/tcPatSynPat (via splitConTyArgs) to pass the type arguments + onto tcConTyArgs and the value arguments onto tcConValArgs. + See Note [Type applications in patterns] for more details. + +2. In tcPatToExpr, to discard the type arguments in the RHS of an implicitly + bidirectional pattern synonym, keeping only the value arguments. + See Note [Discarding types in the builder expression] in GHC.Tc.TyCl.PatSyn. +-} tcConTyArgs :: Subst -> PatEnv -> [(HsTyPat GhcRn, TyVar)] -> TcM a -> TcM a ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -940,11 +940,9 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) | isUnidirectional dir = return [] - | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why - - | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn ps_name + | otherwise -- Bidirectional + = do { match_group <- get_match_group + ; patsyn <- tcLookupPatSyn ps_name ; case patSynBuilder patsyn of { Nothing -> return [] ; -- This case happens if we found a type error in the @@ -985,10 +983,10 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) ; return builder_binds } } } where - mb_match_group + get_match_group = case dir of - ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) + ExplicitBidirectional explicit_mg -> return explicit_mg + ImplicitBidirectional -> mk_mg <$> tcPatToExpr ps_name args lpat Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) @@ -1032,44 +1030,53 @@ add_void need_dummy_arg ty | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: [LocatedN Name] -> LPat GhcRn - -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) +tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn -> TcM (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the -- input uses constructors from HsPat and the output uses constructors -- from HsExpr. -- --- Returns (Left r) if the pattern is not invertible, for reason r. +-- Fails with TcRnPatSynInvalidRhs if the pattern is not invertible. -- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr args pat = go pat +tcPatToExpr ps_name args pat = go pat where lhsVars = mkNameSet (map unLoc args) + invalidRhs :: PatSynInvalidRhsReason -> TcM a + invalidRhs why = setSrcSpan (getLocA pat) $ + failWithTc $ TcRnPatSynInvalidRhs ps_name pat args why + -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: LocatedN (WithUserRdr Name) -> [LPat GhcRn] - -> Either PatSynInvalidRhsReason (HsExpr GhcRn) - mkPrefixConExpr lcon@(L loc _) pats - = do { exprs <- mapM go pats + -> TcM (HsExpr GhcRn) + mkPrefixConExpr lcon@(L loc con_name) pats + = do { con_like <- tcLookupConLike con_name + ; let tvbs = conLikeUserTyVarBinders con_like + ; (_ty_pats, val_pats) <- zipPatsBndrs pats tvbs + -- Type arguments _ty_pats are discarded, just like the SigPat's type. + -- See Note [Discarding types in the builder expression] + ; let ty_exprs = [wildCardTyArg | tvb <- tvbs, isVisibleForAllTyBinder tvb] + -- Placeholders `_` for the discarded required type arguments. + ; val_exprs <- mapM go val_pats ; let con = L (l2l loc) (HsVar noExtField lcon) - ; return (unLoc $ mkHsApps con exprs) - } + ; return (unLoc $ mkHsApps con (ty_exprs ++ val_exprs)) } mkRecordConExpr :: LocatedN (WithUserRdr Name) -> HsRecFields GhcRn (LPat GhcRn) - -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + -> TcM (HsExpr GhcRn) mkRecordConExpr con (HsRecFields x fields dd) = do { exprFields <- mapM go' fields ; return (RecordCon noExtField con (HsRecFields x exprFields dd)) } - go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn)) + go' :: LHsRecField GhcRn (LPat GhcRn) -> TcM (LHsRecField GhcRn (LHsExpr GhcRn)) go' (L l rf) = L l <$> traverse go rf - go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) + go :: LPat GhcRn -> TcM (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + go1 :: Pat GhcRn -> TcM (HsExpr GhcRn) go1 (ConPat NoExtField con info) = case info of PrefixCon _ ps -> mkPrefixConExpr con ps @@ -1077,13 +1084,13 @@ tcPatToExpr args pat = go pat RecCon _ fields -> mkRecordConExpr con fields go1 (SigPat _ pat _) = go1 (unLoc pat) - -- See Note [Type signatures and the builder expression] + -- See Note [Discarding types in the builder expression] go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars = return $ mkHsVar (L l var) | otherwise - = Left (PatSynUnboundVar var) + = invalidRhs (PatSynUnboundVar var) go1 (ParPat _ pat) = fmap (HsPar noExtField) (go pat) go1 (ListPat _ pats) = do { exprs <- mapM go pats @@ -1104,10 +1111,7 @@ tcPatToExpr args pat = go pat | otherwise = return $ HsOverLit noExtField n go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" - go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp) - where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn - hstp_to_hswc (HsTP { hstp_ext = HsTPRn { hstp_nwcs = wcs }, hstp_body = hs_ty }) - = HsWC { hswc_ext = wcs, hswc_body = hs_ty } + go1 (EmbTyPat _ _tp) = panic "tcPatToExpr: invalid type pattern" go1 (InvisPat _ _tp) = panic "tcPatToExpr: invalid invisible pattern" go1 (XPat (HsPatExpanded _ pat))= go1 pat @@ -1131,7 +1135,11 @@ tcPatToExpr args pat = go pat go1 p@(NPlusKPat {}) = notInvertible p go1 p@(OrPat {}) = notInvertible p - notInvertible p = Left (PatSynNotInvertible p) + notInvertible p = invalidRhs (PatSynNotInvertible p) + +-- See Note [Discarding types in the builder expression] +wildCardTyArg :: LHsExpr GhcRn +wildCardTyArg = wrapGenSpan (HsHole (HoleVar (wrapGenSpan unnamedHoleRdrName))) {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1203,9 +1211,17 @@ one could write a nonsensical function like or g (K (Just True) False) = ... -Note [Type signatures and the builder expression] +Note [Discarding types in the builder expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RHS of an implicitly bidirectional pattern synonym may mention types in +three ways: a pattern signature (p :: ty), an invisible type argument (@ty), +and a required type argument (type ty). Required type arguments may be obscured +by the omission of the `type` keyword. + +A type may /bind/ variables when it occurs in a pattern, and those binders have +no counterpart in the builder's scope, so tcPatToExpr must not carry them over. Consider + pattern L x = Left x :: Either [a] [b] In tc{Infer/Check}PatSynDecl we will check that the pattern has the @@ -1223,6 +1239,71 @@ latter; #9867.) No, the job of the signature is done, so when converting the pattern to an expression (for the builder RHS) we simply discard the signature. +The same reasoning applies to the other two forms, but the way we discard +them differs. Which form an argument takes is not apparent from the pattern +alone: in + + pattern P x = MkT a x + +'a' looks like an ordinary variable pattern, and only the TyVarBinders in +MkT's type say that it stands in a required type argument position. We get +those binders from the typechecked ConLike, via conLikeUserTyVarBinders, so +mkPrefixConExpr must look the constructor up before it can walk the arguments. +It then lines them up against the binders with zipPatsBndrs, as described +in Note [Zipping ConPat arguments with TyVarBinders] in GHC.Tc.Gen.Pat. + +Each argument is then treated accordingly: + +* Invisible type arguments (@ty) are dropped from the argument list + altogether. Given + + pattern Q x = MkT @a x + + the builder is $bQ x = MkT x. Dropping is safe because the argument + instantiates either a universal, which the expected type of the builder + already pins down, or an existential, which cannot take a concrete type + in a pattern anyway. Improper handling of type arguments led to #27440. + +* Required type arguments cannot be dropped, as that would change the syntactic + arity of the application. Instead, we replace them with wildcards `_`, the + equivalent of @_ for invisible type arguments. Given + + pattern R x = MkT (type a) x + pattern P x = MkT a x + + the builders are $bR x = MkT _ x and $bP x = MkT _ x, and the wildcard is + solved from the expected type. Retaining the type would mention a binder that + is not in scope in the builder (#27583). + +This reasoning holds when the RHS is a data constructor. Two caveats: + +* With a helper pattern synonym we can construct an example where discarding + the type argument rejects an otherwise valid program: + + pattern Q :: forall a. Show a => Int -> S -- 'a' is ambiguous + pattern P n = Q @Bool n -- rejected: $bP n = Q n, ambiguous 'a' + + The example introduces an ambiguous type variable occurring in a class + constraint. Such a variable serves no purpose, so we do not expect to + encounter this problem in practice. The workaround is to declare P + explicitly bidirectional and write the builder by hand. + +* A required type argument that binds a variable yields a suboptimal error + message: we fail to solve the wildcard, where we would rather report that 'a' + is not bound on the LHS. + + data S where MkS :: forall a -> Show a => Int -> S + pattern P n = MkS a n -- $bP n = MkS _ n, ambiguous wildcard + + Mind you, the program is rejected either way: it is not possible to bind 'a' on + the LHS until pattern synonyms support RequiredTypeArguments (#23704) or + TypeAbstractions (#27642). + +We will have to revisit this design once we do add support for those extensions +in pattern synonym declarations (#23704, #27642). When type variables can be +bound on the LHS, the builder has a scope for them, and discarding every type in +the RHS is no longer the obvious thing to do. + Note [Record PatSyn Desugaring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is important that prov_theta comes before req_theta as this ordering is used ===================================== testsuite/tests/patsyn/should_compile/T27440a.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds, PatternSynonyms, TypeAbstractions #-} +module T27440a where + +import Data.Kind (Type) + +newtype Lit = Lit { litName :: String } + +type LitOfValue :: Bool -> Type +newtype LitOfValue v = LitOfValue { underlyingLit :: Lit } + +pattern FalseLit :: Lit -> LitOfValue False +pattern FalseLit a = LitOfValue @False a ===================================== testsuite/tests/patsyn/should_compile/T27440b.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms, TypeAbstractions #-} +module T27440b where + +data T a = MkT a + +pattern P :: a -> T a +pattern P x = MkT @a x ===================================== testsuite/tests/patsyn/should_compile/T27440c.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, TypeAbstractions #-} +module T27440c where + +data S = forall a. Show a => MkS a + +pattern P :: () => Show a => a -> S +pattern P x = MkS @a x ===================================== testsuite/tests/patsyn/should_compile/all.T ===================================== @@ -90,3 +90,7 @@ test('T23038', normal, compile_fail, ['']) test('T22328', normal, compile, ['']) test('T26331', normal, compile, ['']) test('T26331a', normal, compile, ['']) + +test('T27440a', normal, compile, ['']) +test('T27440b', normal, compile, ['']) +test('T27440c', normal, compile, ['']) ===================================== testsuite/tests/patsyn/should_fail/T27440d.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, TypeAbstractions #-} +module T27440d where + +data S = forall a. Show a => MkS a + +pattern P :: Show a => a -> S +pattern P x = MkS @a x ===================================== testsuite/tests/patsyn/should_fail/T27440d.stderr ===================================== @@ -0,0 +1,12 @@ +T27440d.hs:7:22: error: [GHC-25897] + • Couldn't match expected type ‘a’ with actual type ‘a1’ + ‘a1’ is a rigid type variable bound by + a pattern with constructor: MkS :: forall a. Show a => a -> S, + in a pattern synonym declaration + at T27440d.hs:7:15-22 + ‘a’ is a rigid type variable bound by + the signature for pattern synonym ‘P’ + at T27440d.hs:6:14-29 + • In the declaration for pattern synonym ‘P’ + • Relevant bindings include x :: a1 (bound at T27440d.hs:7:22) + ===================================== testsuite/tests/patsyn/should_fail/all.T ===================================== @@ -55,3 +55,5 @@ test('patsyn_where_fail1', normal, compile_fail, ['']) test('patsyn_where_fail2', normal, compile_fail, ['']) test('patsyn_where_fail3', normal, compile_fail, ['']) test('patsyn_where_fail4', normal, compile_fail, ['']) + +test('T27440d', normal, compile_fail, ['']) ===================================== testsuite/tests/vdq-rta/should_compile/T27583a.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583a where + +data T a where + MkT :: forall a -> T a + +pattern P :: T a +pattern P = MkT (type a) ===================================== testsuite/tests/vdq-rta/should_compile/T27583b.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583b where + +data T a where + MkT :: forall a -> T a + +pattern P :: T a +pattern P = MkT a ===================================== testsuite/tests/vdq-rta/should_compile/T27583c.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583c where + +data T a where + MkT :: forall a -> T a + +pattern P :: T Int +pattern P = MkT (type Int) ===================================== testsuite/tests/vdq-rta/should_compile/T27583d.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583d where + +data T a where + MkT :: forall a -> a -> T a + +-- A required type argument is checked against the signature, with or without +-- the 'type' herald. The variable/wildcard patterns x, _, (type x), (type _) +-- can't mismatch the signature. Concrete types are in T27583e and T27583f. + +pattern P1 :: Int -> T Int +pattern P1 n = MkT x n + +pattern P2 :: Int -> T Int +pattern P2 n = MkT (type x) n + +pattern P3 :: Int -> T Int +pattern P3 n = MkT _ n + +pattern P4 :: Int -> T Int +pattern P4 n = MkT (type _) n ===================================== testsuite/tests/vdq-rta/should_compile/T27583e.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583e where + +data T a where + MkT :: forall a -> a -> T a + +-- A required type argument is checked against the signature, with or without +-- the 'type' herald. Here the type written in that position agrees with the +-- signature. T27583f is the same four patterns with a type that does not. + +pattern P1 :: Int -> T Int +pattern P1 n = MkT Int n + +pattern P2 :: Int -> T Int +pattern P2 n = MkT (type Int) n + +pattern P3 :: Maybe Int -> T (Maybe Int) +pattern P3 n = MkT (Maybe Int) n + +pattern P4 :: Maybe Int -> T (Maybe Int) +pattern P4 n = MkT (type (Maybe Int)) n ===================================== testsuite/tests/vdq-rta/should_compile/T27583g.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms, TypeAbstractions #-} +module T27583g where + +data T a b c where + MkT :: forall a. forall b c -> a -> T a b c + +-- Check all argument variants in a constructor pattern at once: the invisible +-- type argument `@a`, the required type argument `type b` with the herald, the +-- required type argument `c` without the herald, and the value argument `x`. +-- +-- The resulting builder is $bP x = MkT _ _ x. + +pattern P :: x -> T x y z +pattern P x = MkT @a (type b) c x ===================================== testsuite/tests/vdq-rta/should_compile/all.T ===================================== @@ -39,3 +39,10 @@ test('T23738_th', req_th, compile, ['']) test('T24159_viewpat', normal, compile, ['']) test('T24159_type_syntax', normal, compile, ['']) test('T24159_th_type_syntax', req_th, compile, ['']) + +test('T27583a', normal, compile, ['']) +test('T27583b', normal, compile, ['']) +test('T27583c', normal, compile, ['']) +test('T27583d', normal, compile, ['']) +test('T27583e', normal, compile, ['']) +test('T27583g', normal, compile, ['']) ===================================== testsuite/tests/vdq-rta/should_fail/T27440e.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms, TypeAbstractions #-} +module T27440e where + +data T a where + MkT :: forall a -> T a + +pattern P :: a -> T a +pattern P x = MkT @a x ===================================== testsuite/tests/vdq-rta/should_fail/T27440e.stderr ===================================== @@ -0,0 +1,5 @@ +T27440e.hs:8:19: error: [GHC-88754] + • Ill-formed type pattern: @a + • In the pattern: MkT @a x + In the declaration for pattern synonym ‘P’ + ===================================== testsuite/tests/vdq-rta/should_fail/T27583f.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583f where + +data T a where + MkT :: forall a -> a -> T a + +-- A required type argument is checked against the signature, with or without +-- the 'type' herald. Here the type written in that position does not agree +-- with the signature. T27583e is the same four patterns with a type that does. + +pattern P1 :: Int -> T Int +pattern P1 n = MkT Bool n + +pattern P2 :: Int -> T Int +pattern P2 n = MkT (type Bool) n + +pattern P3 :: Maybe Int -> T (Maybe Int) +pattern P3 n = MkT (Maybe Bool) n + +pattern P4 :: Maybe Int -> T (Maybe Int) +pattern P4 n = MkT (type (Maybe Bool)) n ===================================== testsuite/tests/vdq-rta/should_fail/T27583f.stderr ===================================== @@ -0,0 +1,24 @@ +T27583f.hs:12:16: error: [GHC-83865] + • Couldn't match expected type ‘Int’ with actual type ‘Bool’ + • In the pattern: MkT Bool n + In the declaration for pattern synonym ‘P1’ + +T27583f.hs:15:16: error: [GHC-83865] + • Couldn't match expected type ‘Int’ with actual type ‘Bool’ + • In the pattern: MkT (type Bool) n + In the declaration for pattern synonym ‘P2’ + +T27583f.hs:18:16: error: [GHC-83865] + • Couldn't match type ‘Bool’ with ‘Int’ + Expected: Maybe Int + Actual: Maybe Bool + • In the pattern: MkT (Maybe Bool) n + In the declaration for pattern synonym ‘P3’ + +T27583f.hs:21:16: error: [GHC-83865] + • Couldn't match type ‘Bool’ with ‘Int’ + Expected: Maybe Int + Actual: Maybe Bool + • In the pattern: MkT (type (Maybe Bool)) n + In the declaration for pattern synonym ‘P4’ + ===================================== testsuite/tests/vdq-rta/should_fail/all.T ===================================== @@ -32,3 +32,6 @@ test('T24159_type_syntax_tc_fail', normal, compile_fail, ['']) test('T24159_type_syntax_th_fail', normal, ghci_script, ['T24159_type_syntax_th_fail.script']) test('T25127_fail_th_quote', normal, compile_fail, ['']) test('T25127_fail_arity', normal, compile_fail, ['']) + +test('T27440e', normal, compile_fail, ['']) +test('T27583f', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f98510802423dcd98fa62af7799718… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f98510802423dcd98fa62af7799718… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] mkWpFun_FRR: fix ordering of coercion composition
by Marge Bot (＠marge-bot) 07 Aug '26

07 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: eb1dcd4d by sheaf at 2026-08-07T17:50:40-04:00 mkWpFun_FRR: fix ordering of coercion composition When the subsumption machinery generates an eta-expansion, we must perform a representation polymorphism check to ensure the lambda binder it introduces has a fixed runtime representation. This is done in GHC.Tc.Utils.mkWpFun_FRR. This check involves composing quite a few coercions, arising from representation-polymorphism checks on both the actual and expected argument types. These coercions are then chained using HsWrapper composition, <.>. The ordering of composition was incorrect, leading to the Core Lint failure reported in #27639. This commit fixes that. Fixes #27639 - - - - - 4 changed files: - + changelog.d/T27639 - compiler/GHC/Tc/Utils/Unify.hs - + testsuite/tests/rep-poly/T27639.hs - testsuite/tests/rep-poly/all.T Changes: ===================================== changelog.d/T27639 ===================================== @@ -0,0 +1,10 @@ +section: compiler +issues: #27639 +mrs: !16474 +synopsis: + Stop representation-polymorphism checks from producing a coercion that fails + Core Lint. +description: + The representation-polymorphism check that is done when subsumption performs + eta-expansion now composes the coercions it builds in the correct order, + avoiding a Core Lint failure. ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -2359,7 +2359,7 @@ mkWpFun_FRR (mb_tc_fun, pos) sub_mult act_af act_mult act_arg act_res exp_af exp act_arg_co (mkNomReflCo act_res) arg_wrap_frr = -- exp_arg_frr ~~> act_arg_frr - mkWpCastN (mkSymCo exp_arg_co) <.> arg_wrap <.> mkWpCastN act_arg_co + mkWpCastN act_arg_co <.> arg_wrap <.> mkWpCastN (mkSymCo exp_arg_co) ; traceTc "mkWpFun_FRR: WpFun" $ vcat [ text "act_mult:" <+> ppr act_mult ===================================== testsuite/tests/rep-poly/T27639.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE DeepSubsumption, RankNTypes, PolyKinds, DataKinds, GADTs, TypeOperators, ScopedTypeVariables #-} +module T27639 where + +import GHC.Exts +import Data.Type.Equality + +h :: forall r (a :: TYPE r) (b :: TYPE r). + (r :~: LiftedRep) -> (a :~: b) -> () +h Refl Refl = + let + v :: a -> (Int -> Int) -> Int + v = undefined + u :: b -> (forall c. c -> c) -> Int + u = v + in () ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -43,6 +43,7 @@ test('T23883c', normal, compile_fail, ['']) test('T23903', normal, compile_fail, ['']) test('T26107', js_broken(22364), compile, ['-O']) test('T26528', normal, compile, ['']) +test('T27639', normal, compile, ['']) test('EtaExpandDataCon', normal, compile, ['-O']) test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb1dcd4d98548b7bc64c323dc352ddb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb1dcd4d98548b7bc64c323dc352ddb… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/ghc-9-14-building-base] Make relative directories absolute
by Wolfgang Jeltsch (＠jeltsch) 07 Aug '26

07 Aug '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC Commits: 256ec94c by Wolfgang Jeltsch at 2026-08-07T22:26:26+03:00 Make relative directories absolute - - - - - 1 changed file: - .gitlab/base-ci.sh Changes: ===================================== .gitlab/base-ci.sh ===================================== @@ -27,6 +27,9 @@ mkdir other-ghcs mkdir other-ghcs/src mkdir other-ghcs/opt +# Save project root +project_root=$PWD + # Create Cabal file for `base` ( cd libraries/base @@ -46,15 +49,16 @@ do >${ghc_version}.tar.xz tar -xJf ${ghc_version}.tar.xz cd ghc-${ghc_version}-* - ./configure --prefix "../../opt/${ghc_version}" + ./configure --prefix "${project_root}/opt/${ghc_version}" make install ) # Build `base` with the installed GHC ( cd libraries/base - cabal build --with-compiler ../../other-ghcs/opt/${ghc_version}/bin/ghc \ - --allow-boot-library-installs \ - -O0 + cabal build + --with-compiler "${project_root}/other-ghcs/opt/${ghc_version}/bin/ghc" \ + --allow-boot-library-installs \ + -O0 ) done View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/256ec94c2189177bcab6d1475aacb0a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/256ec94c2189177bcab6d1475aacb0a… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] 2 commits: Improve the normalization script
by Wolfgang Jeltsch (＠jeltsch) 07 Aug '26

07 Aug '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: 070e240b by Wolfgang Jeltsch at 2026-08-07T13:55:22+03:00 Improve the normalization script - - - - - 882c3603 by Wolfgang Jeltsch at 2026-08-07T22:14:22+03:00 Fix JavaScript test output - - - - - 3 changed files: - testsuite/tests/show-bytecode/normalize - testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-javascript-unknown-ghcjs - testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-javascript-unknown-ghcjs Changes: ===================================== testsuite/tests/show-bytecode/normalize ===================================== @@ -2,6 +2,7 @@ set -e -o pipefail +# Make the test output independent of unstable compiler-generated data stabilize () { sed -E -e ' @@ -12,15 +13,17 @@ stabilize () ' } +# Make the test output independent of the word size universalize () { sed -E -e ' - s/UInt[[:digit:]]+/UInt@word_size@/ s/W[[:digit:]]+#/W@word_size@#/ + s/UInt[[:digit:]]+/UInt@word_size@/ ' | uniq # The invocation of `uniq` is merely for collapsing adjacent entries of # `word @large_word@`, whose number may depend on the word size. } +# Run all phases stabilize | universalize ===================================== testsuite/tests/show-bytecode/show-bytecode-breakpoints.stdout-javascript-unknown-ghcjs ===================================== @@ -322,12 +322,12 @@ objects: object ‘cstrlen’: arity: 2 literals: <none> - used items: - object ‘ds1_@name_suffix@’: used items: named item ‘cstrlen1_@name_suffix@’ object ‘cstrlen1_@name_suffix@’: arity: 2 literals: <none> + used items: + object ‘ds1_@name_suffix@’: arity: 0 literals: label ‘strlen’ ===================================== testsuite/tests/show-bytecode/show-bytecode-vanilla.stdout-javascript-unknown-ghcjs ===================================== @@ -271,6 +271,10 @@ objects: named item ‘$tcNatural’ named item ‘mkTrCon’ object ‘cstrlen’: + arity: 2 + literals: <none> + used items: named item ‘cstrlen1_@name_suffix@’ + object ‘cstrlen1_@name_suffix@’: arity: 2 literals: <none> used items: @@ -324,10 +328,6 @@ objects: static-construction object ‘$tc'PerfectTree’: data constructor: TyCon lifted: yes - used items: named item ‘cstrlen1_@name_suffix@’ - object ‘cstrlen1_@name_suffix@’: - arity: 2 - literals: <none> literals: word @large_word@ word 1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d922982b667569c414d0cfd7509fe6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d922982b667569c414d0cfd7509fe6… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Cmm: print unreachable blocks under -dppr-debug (#27368)
by Marge Bot (＠marge-bot) 07 Aug '26

07 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0779e12c by Simon Jakobi at 2026-08-07T12:36:11-04:00 Cmm: print unreachable blocks under -dppr-debug (#27368) Unreachable blocks linger in a CmmGraph's block map for most of the Cmm pipeline, but pprCmmGraph only ever printed the blocks reachable from the entry, so dumps looked consistent while the graph was not. Issues like #27368 were hard to debug due to this. pprCmmGraph now appends the stored-but-unreachable blocks under a "// unreachable blocks:" heading when -dppr-debug is on. See Note [unreachable blocks] in GHC.Cmm.Pipeline. Assisted-by: Claude Opus 5 - - - - - 3a0f9a51 by Simon Peyton Jones at 2026-08-07T12:36:54-04:00 Fix three bugs related to required type args and INLINE pragmas * `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front, leading to a Lint error (#27557) * The arity in an InlineSaturation is the VisArity not the Arity; the two can differ when we have "required" type arguments. This made the INLINE pragma argument counting go wrong in `makeCorePair` (#27590). * When a simple binding has a type signature, we take special path in `tcPolyCheck`, leading to an outer `AbsBinds` that has no dictionaries, even when the binding is in fact overloaded. That confused the inline-arity computation in `makeCorePair` (#27589). The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`. That actually simplifies the API of `makeCorePair`, which is nice. The first bug is fixed by swapping the visiblity flags in `GHC.Core.Opt.Arity.mkEtaForAllMCo` Getting the INLINE behaviour right led to some perf changes: * Runtime /halved/ on T7954 due to better specialisation * Compile time increased by 6% in T21839c because a bit more inlining happened, as it always should have done. * For some reason compile-time max-bytes-used dropped by 30% on T27336, but only on one build configuration; and it increased on LinkableUsage02 by 6% on another configuration Geometric mean effect on our compile time benchmarks is +0.1%. Metric Decrease: T27336 T7954 Metric Increase: LinkableUsage02 T21839c - - - - - 8a95ce02 by Vladislav Zavialov at 2026-08-07T13:09:13-04:00 Discard type arguments in tcPatToExpr (#27440, #27583) The builder expression of an implicitly bidirectional pattern synonym must not mention types written in the RHS: * Invisible type arguments led to a panic (#27440) * Required type arguments failed with out-of-scope variables (#27583) Both are now discarded, following the precedent established by pattern signatures (#9867). Discarding type arguments takes some care: a type pattern cannot be told from a value pattern by syntax alone, as the `type` keyword may be omitted. Consider: data T a b c where MkT :: forall a. forall b c -> a -> T a b c pattern P :: x -> T x y z pattern P x = MkT @a (type b) c x In P's right-hand side, `@a` and `type b` are clearly type arguments, but what about `c` and `x`? We can only tell by matching the patterns against MkT's type. So tcPatToExpr now runs in TcM and matches the arguments against the constructor's TyVarBinders using zipPatsBndrs, which is made public for this purpose. The resulting builder is $bP x = MkT _ _ x. See Note [Discarding types in the builder expression]. Test cases: T27440a T27440b T27440c T27440d T27440e T27583a T27583b T27583c T27583d T27583e T27583f T27583g Metric Increase: LinkableUsage02 Metric Decrease: T27336 Assisted-by: Claude Opus 5 - - - - - 9787e836 by sheaf at 2026-08-07T13:09:32-04:00 mkWpFun_FRR: fix ordering of coercion composition When the subsumption machinery generates an eta-expansion, we must perform a representation polymorphism check to ensure the lambda binder it introduces has a fixed runtime representation. This is done in GHC.Tc.Utils.mkWpFun_FRR. This check involves composing quite a few coercions, arising from representation-polymorphism checks on both the actual and expected argument types. These coercions are then chained using HsWrapper composition, <.>. The ordering of composition was incorrect, leading to the Core Lint failure reported in #27639. This commit fixes that. Fixes #27639 - - - - - 57 changed files: - + changelog.d/T27368-ppr-unreachable-cmm-blocks.md - + changelog.d/T27440 - + changelog.d/T27557 - + changelog.d/T27583 - + changelog.d/T27589 - + changelog.d/T27639 - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Var.hs - docs/users_guide/debugging.rst - libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.cmm - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/patsyn/should_compile/T27440a.hs - + testsuite/tests/patsyn/should_compile/T27440b.hs - + testsuite/tests/patsyn/should_compile/T27440c.hs - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T27440d.hs - + testsuite/tests/patsyn/should_fail/T27440d.stderr - testsuite/tests/patsyn/should_fail/all.T - + testsuite/tests/rep-poly/T27639.hs - testsuite/tests/rep-poly/all.T - + testsuite/tests/simplCore/should_compile/T27589.hs - + testsuite/tests/simplCore/should_compile/T27589.stderr - + testsuite/tests/simplCore/should_compile/T27590.hs - + testsuite/tests/simplCore/should_compile/T27590.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T27557.hs - testsuite/tests/typecheck/should_compile/all.T - + testsuite/tests/vdq-rta/should_compile/T27583a.hs - + testsuite/tests/vdq-rta/should_compile/T27583b.hs - + testsuite/tests/vdq-rta/should_compile/T27583c.hs - + testsuite/tests/vdq-rta/should_compile/T27583d.hs - + testsuite/tests/vdq-rta/should_compile/T27583e.hs - + testsuite/tests/vdq-rta/should_compile/T27583g.hs - testsuite/tests/vdq-rta/should_compile/all.T - + testsuite/tests/vdq-rta/should_fail/T27440e.hs - + testsuite/tests/vdq-rta/should_fail/T27440e.stderr - + testsuite/tests/vdq-rta/should_fail/T27583f.hs - + testsuite/tests/vdq-rta/should_fail/T27583f.stderr - testsuite/tests/vdq-rta/should_fail/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5a067d449bb25f202b72594ad6f36… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5a067d449bb25f202b72594ad6f36… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/torsten.schmits/mwb-26-07/abstract-linkables] 2 commits: WIP Abstract getLinkDeps
by Torsten Schmits (＠torsten.schmits) 07 Aug '26

07 Aug '26

Torsten Schmits pushed to branch wip/torsten.schmits/mwb-26-07/abstract-linkables at Glasgow Haskell Compiler / GHC Commits: 642a9794 by Torsten Schmits at 2026-08-07T18:55:45+02:00 WIP Abstract getLinkDeps - - - - - 79964a8f by Torsten Schmits at 2026-08-07T18:55:45+02:00 WIP Make extra_decls lazy when loading from Binary - - - - - 5 changed files: - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Unit/Module/ModIface.hs Changes: ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -3,6 +3,8 @@ module GHC.Driver.Env.Types ( Hsc(..) , HscEnv(..) + , LinkDeps (..) + , Linkables (..) ) where import GHC.Driver.Errors.Types ( GhcMessage ) @@ -29,6 +31,10 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.IORef import GHC.Driver.Env.KnotVars +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Linker.Types (Linkable, LoaderState) +import GHC.Unit.Types (UnitId, Module) +import GHC.Types.Unique.DSet (UniqDSet) -- | The Hsc monad: Passing an environment and diagnostic state newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)) @@ -44,6 +50,18 @@ instance ContainsDynFlags HscEnv where instance HasLogger Hsc where getLogger = Hsc $ \e w -> return (hsc_logger e, w) +data LinkDeps = LinkDeps + { ldNeededLinkables :: [Linkable] + , ldAllLinkables :: [Linkable] + , ldNeededUnits :: [UnitId] + , ldAllUnits :: UniqDSet UnitId + } + +data Linkables where + Linkables :: { + linkablesResolve :: SrcSpan -> [Module] -> IO a, + linkablesSelect :: a -> IO LinkDeps + } -> Linkables -- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source @@ -87,6 +105,8 @@ data HscEnv -- ^ target code interpreter (if any) to use for TH and GHCi. -- See Note [Target code interpreter] + , hsc_linkables :: HscEnv -> LoaderState -> IO Linkables + , hsc_plugins :: !Plugins -- ^ Plugins ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -342,6 +342,7 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do , hsc_FC = fc_var , hsc_type_env_vars = emptyKnotVars , hsc_interp = Nothing + , hsc_linkables = linkablesDefault , hsc_unit_env = unit_env , hsc_plugins = emptyPlugins , hsc_hooks = emptyHooks @@ -2880,10 +2881,10 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do -- Take lock for the actual work. (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do - let link_opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required - deps <- getLinkDeps link_opts interp pls srcspan needed_mods + linkables <- hsc_linkables hsc_env hsc_env pls + deps <- linkablesGet linkables srcspan needed_mods -- We update the LinkerState even if the JS interpreter maintains its linker -- state independently to load new objects here. ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -12,6 +12,12 @@ module GHC.Linker.Deps ( LinkDepsOpts (..) , LinkDeps (..) , getLinkDeps + , Linkables (..) + , LinkDep (..) + , LinkModule (..) + , linkablesGet + , resolveLinkDeps + , selectLinkDeps ) where @@ -42,16 +48,13 @@ import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo import GHC.Iface.Errors.Types -import GHC.Iface.Errors.Ppr import GHC.Utils.Misc import GHC.Unit.Home -import qualified GHC.Unit.Home.Graph as HUG import GHC.Data.Maybe import Control.Applicative import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Foldable (traverse_) import qualified Data.Set as Set @@ -60,11 +63,8 @@ import Data.List (isSuffixOf) import System.FilePath import System.Directory import GHC.Utils.Logger (Logger) -import Control.Monad ((<$!>)) -import GHC.Driver.Env -import {-# SOURCE #-} GHC.Driver.Main -import Data.Time.Clock import GHC.Unit.Home.Graph +import GHC.Driver.Env.Types (Linkables (..), LinkDeps (..)) data LinkDepsOpts = LinkDepsOpts @@ -86,12 +86,9 @@ data LinkDepsOpts = LinkDepsOpts , ldLogger :: !Logger } -data LinkDeps = LinkDeps - { ldNeededLinkables :: [Linkable] - , ldAllLinkables :: [Linkable] - , ldNeededUnits :: [UnitId] - , ldAllUnits :: UniqDSet UnitId - } +linkablesGet :: Linkables -> SrcSpan -> [Module] -> IO LinkDeps +linkablesGet Linkables {..} span mods = + linkablesSelect =<< linkablesResolve span mods -- | Find all the packages and linkables that a set of modules depends on -- @@ -108,14 +105,8 @@ getLinkDeps -> [Module] -- If you need these -> IO LinkDeps -- ... then link these first getLinkDeps opts interp pls span mods = do - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay opts interp span - - withTiming (ldLogger opts) (text "getLinkDeps" <+> brackets (ppr span)) (const ()) $ - get_link_deps opts pls maybe_normal_osuf span mods + linkables <- resolveLinkDeps opts pls span mods + selectLinkDeps opts interp span linkables -- | Determine which parts of a module and its dependencies should be linked -- when resolving external dependencies. @@ -151,7 +142,7 @@ data LinkExternal = } instance Outputable LinkExternal where - ppr LinkExternal {..} = ppr le_module <> brackets (ppr le_details) + ppr LinkExternal {..} = ppr le_module Outputable.<> brackets (ppr le_details) -- | The decision about the linking method used for a given module. data LinkModule = @@ -180,48 +171,31 @@ instance Outputable LinkModule where LinkObjectModule mod _ -> ppr mod LinkByteCodeModule mod _ -> ppr mod <+> brackets (text "BC") --- | Compute the linkables for the given module set's dependencies. --- --- Home modules in make mode are treated separately in a preprocessing step, --- then all the remaining external deps are processed for both modes. --- If bytecode is available, transitive external deps are included, otherwise --- the module's library is linked and processing stops. --- --- The results are split into sets of needed/loaded modules/packages. -get_link_deps - :: LinkDepsOpts - -> LoaderState - -> Maybe FilePath -- replace object suffixes? - -> SrcSpan - -> [Module] - -> IO LinkDeps -get_link_deps opts pls maybe_normal_osuf span mods = do - (link_deps_home, module_deps_external) <- separate_home_deps - link_deps_external <- external_deps opts module_deps_external - let (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) = - classify_deps pls link_deps_home link_deps_external - ldNeededLinkables <- mapM module_linkable needed_modules - pure LinkDeps { - ldNeededLinkables, - ldAllLinkables = loaded_modules ++ ldNeededLinkables, - ldNeededUnits, - ldAllUnits - } +resolveLinkDeps :: + LinkDepsOpts -> + LoaderState -> + SrcSpan -> + [Module] -> + IO ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) +resolveLinkDeps opts pls span mods = + withTiming (ldLogger opts) (text "getLinkDeps" <+> brackets (ppr span)) (const ()) $ do + (link_deps_home, module_deps_external) <- separate_home_deps + link_deps_external <- external_deps opts module_deps_external + pure (classify_deps pls link_deps_home link_deps_external) where mod_graph = ldModuleGraph opts unit_env = ldUnitEnv opts noninteractive = filterOut isInteractiveModule mods - -- Preprocess the dependencies in make mode to remove all home modules, - -- since the transitive dependency closure is already cached for those in - -- the HUG (see MultiLayerModulesTH_* tests for the performance impact). + -- Preprocess the dependencies to remove all home modules, since the + -- transitive dependency closure is already cached for those in the HUG + -- (see MultiLayerModulesTH_* tests for the performance impact). -- - -- Returns the remaining, external, dependencies on the right, which is the - -- entire set for oneshot mode. - separate_home_deps = - if ldOneShotMode opts - then pure ([], LinkExternal LinkAllDeps <$!> noninteractive) - else make_deps + -- Returns the remaining, external, dependencies on the right. + -- This function only supports make mode; oneshot mode (in which the + -- entire dependency set would be treated as external) is not used by + -- this worker and is not supported here. + separate_home_deps = make_deps make_deps = do (dep_ext, mmods) <- unzip <$> mapM get_mod_info all_home_mods @@ -265,6 +239,22 @@ get_link_deps opts pls maybe_normal_osuf span mods = do Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid +select_link_deps + :: LinkDepsOpts + -> Maybe FilePath -- replace object suffixes? + -> SrcSpan + -> ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + -> IO LinkDeps +select_link_deps opts maybe_normal_osuf span (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) = do + ldNeededLinkables <- mapM module_linkable needed_modules + pure LinkDeps { + ldNeededLinkables, + ldAllLinkables = loaded_modules ++ ldNeededLinkables, + ldNeededUnits, + ldAllUnits + } + where + no_obj :: Outputable a => a -> IO b no_obj mod = dieWith opts span $ text "cannot find object file for module" <+> @@ -277,7 +267,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- results. module_linkable = \case LinkHomeModule hmi -> - adjust_linkable (expectJust "getLinkDeps" (homeModLinkable hmi)) + adjust_linkable (expectJust "foo" (homeModLinkable hmi)) LinkObjectModule mod loc -> do findObjectLinkableMaybe mod loc >>= \case @@ -321,6 +311,20 @@ get_link_deps opts pls maybe_normal_osuf span mods = do CoreBindings WholeCoreBindings {wcb_module} -> pprPanic "Unhydrated core bindings" (ppr wcb_module) +selectLinkDeps + :: LinkDepsOpts + -> Interp + -> SrcSpan -- for error messages + -> ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + -> IO LinkDeps -- ... then link these first +selectLinkDeps opts interp span linkables = do + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay opts interp span + select_link_deps opts maybe_normal_osuf span linkables + data LinkDep = LinkModules !(UniqDFM ModuleName LinkModule) | @@ -331,11 +335,6 @@ instance Outputable LinkDep where LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods) LinkLibrary uid -> text "library:" <+> ppr uid -data OneshotError = - NoInterface !MissingInterfaceError - | - LinkBootModule !Module - -- | Compute the transitive dependency closure of the given modules. -- -- Used for all oneshot mode dependencies and for external dependencies of home @@ -346,21 +345,13 @@ external_deps :: [LinkExternal] -> IO [LinkDep] external_deps opts mods = - runExceptT (external_deps_loop opts mods emptyUDFM) >>= \case - Right a -> pure (eltsUDFM a) - Left err -> throwProgramError opts (message err) - where - message = \case - NoInterface err -> - missingInterfaceErrorDiagnostic (ldMsgOpts opts) err - LinkBootModule mod -> - link_boot_mod_error mod + eltsUDFM <$> external_deps_loop opts mods emptyUDFM external_deps_loop :: LinkDepsOpts -> [LinkExternal] -> UniqDFM UnitId LinkDep -> - ExceptT OneshotError IO (UniqDFM UnitId LinkDep) + IO (UniqDFM UnitId LinkDep) external_deps_loop _ [] acc = pure acc external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do @@ -386,8 +377,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do -- link an object file (which happens for home unit modules, since those -- have no libraries). process_module = \case - LinkAllDeps | is_home || package_bc -> try_iface - | otherwise -> add_library + LinkAllDeps -> add_library -- @LinkOnlyPackages@ is used for make mode home modules, so all imports -- that are not external are already processed otherwise. @@ -407,45 +397,9 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do | otherwise = False - -- Load the iface and attempt to get bytecode from Core bindings. - try_iface = - liftIO (ldLoadIface opts load_reason mod) >>= \case - Failed err -> throwE (NoInterface err) - Succeeded (iface, loc) -> do - mb_load_bc <- liftIO (ldLoadByteCode opts (mi_module iface)) - with_iface iface loc mb_load_bc - - -- Decide how to link this module. - -- If bytecode or an object file is available, use those in that order. - -- Otherwise fall back to linking a library. - with_iface iface loc mb_load_bc - | IsBoot <- mi_boot iface - = throwE (LinkBootModule mod) - - | ldUseByteCode opts - , is_home || package_bc - , Just load_bc <- mb_load_bc - = add_module iface (LinkByteCodeModule mod load_bc) "bytecode" - - | is_home - = add_module iface (LinkObjectModule mod loc) "object" - - | otherwise - = add_library - add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [], Just "library") - add_module iface lmod action = - with_deps with_mod iface True action - where - with_mod = alterUDFM (add_package_module lmod) acc mod_unit_id - - add_package_module lmod = \case - Just (LinkLibrary u) -> Just (LinkLibrary u) - Just (LinkModules old) -> Just (LinkModules (addToUDFM old mod_name lmod)) - Nothing -> Just (LinkModules (unitUDFM mod_name lmod)) - with_deps acc iface local action = pure (addListToUDFM acc link, new_local ++ new_package, Just action) where @@ -458,26 +412,17 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do | (_, GWIB m _) <- Set.toList (dep_direct_mods (mi_deps iface)) ] - -- If bytecode linking of external dependencies is enabled, add them to the - -- jobs passed to the next iteration of 'external_deps_loop'. - -- Otherwise, link all package deps as libraries. - package_deps iface - | package_bc - = ([], [LinkExternal LinkAllDeps usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]) - | otherwise - = ([(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) - - load_reason = - text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" - - package_bc = ldPkgByteCode opts - - -- In multiple home unit mode, this only considers modules from the same - -- unit as the splice's module to be eligible for linking bytecode when - -- @-fpackage-db-byte-code@ is off. - -- For make mode, this is irrelevant, since any bytecode from the HUG is - -- obtained directly, not going through 'external_deps'. + -- External package dependencies are always linked as libraries; this + -- worker does not support traversing external package modules for + -- bytecode ("-fpackage-db-byte-code"). + package_deps iface = + ([(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) + + -- Considers only modules from the same unit as the splice's module to be + -- eligible for linking bytecode. + -- For make mode, this is irrelevant for home modules in general, since any + -- bytecode from the HUG is obtained directly, not going through + -- 'external_deps'. is_home | Just home <- ue_homeUnit (ldUnitEnv opts) = homeUnitAsUnit home == mod_unit @@ -489,11 +434,6 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do mod_unit_id = moduleUnitId mod mod_unit = moduleUnit mod -link_boot_mod_error :: Module -> SDoc -link_boot_mod_error mod = - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module" - -- | Split link dependencies into the sets of modules and packages that have -- been linked previously and those that need to be linked now by checking for -- their presence in the 'LoaderState': ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Linker.Loader , rmDupLinkables , modifyLoaderState , initLinkDepsOpts + , linkablesDefault ) where @@ -97,7 +98,6 @@ import Control.Monad import qualified Data.Set as Set import Data.Char (isSpace) import Data.Functor ((<&>)) -import qualified Data.Foldable as Foldable import Data.IORef import Data.List (intercalate, isPrefixOf, nub, partition) import Data.Maybe @@ -115,7 +115,7 @@ import System.Win32.Info (getSystemDirectory) #endif import GHC.Utils.Exception -import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) +import GHC.Unit.Home.Graph (unitEnv_foldWithKey) -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -231,10 +231,10 @@ loadDependencies -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required -- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do - let opts = initLinkDepsOpts hsc_env + linkables <- hsc_linkables hsc_env hsc_env pls -- Find what packages and linkables are required - deps <- getLinkDeps opts interp pls span needed_mods + deps <- linkablesGet linkables span needed_mods let this_pkgs_needed = ldAllUnits deps @@ -683,6 +683,15 @@ initLinkDepsOpts hsc_env = opts EPS {eps_iface_bytecode} <- hscEPS hsc_env pure (lookupModuleEnv eps_iface_bytecode mod) +linkablesDefault :: + HscEnv -> + LoaderState -> + IO Linkables +linkablesDefault hsc_env pls = + pure Linkables { + linkablesResolve = getLinkDeps (initLinkDepsOpts hsc_env) (hscInterp hsc_env) pls, + linkablesSelect = pure + } {- ********************************************************************** ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -503,7 +503,7 @@ instance Binary ModIface where lazyPut bh warns lazyPut bh anns put_ bh decls - put_ bh extra_decls + lazyPut bh extra_decls put_ bh foreign_ put_ bh insts put_ bh fam_insts @@ -536,7 +536,7 @@ instance Binary ModIface where warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh - extra_decls <- get bh + extra_decls <- lazyGet bh foreign_ <- get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff8b945d434a7f2a270a2b09b3f1df… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff8b945d434a7f2a270a2b09b3f1df… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Fix three bugs related to required type args and INLINE pragmas
by Marge Bot (＠marge-bot) 07 Aug '26

07 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3a0f9a51 by Simon Peyton Jones at 2026-08-07T12:36:54-04:00 Fix three bugs related to required type args and INLINE pragmas * `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front, leading to a Lint error (#27557) * The arity in an InlineSaturation is the VisArity not the Arity; the two can differ when we have "required" type arguments. This made the INLINE pragma argument counting go wrong in `makeCorePair` (#27590). * When a simple binding has a type signature, we take special path in `tcPolyCheck`, leading to an outer `AbsBinds` that has no dictionaries, even when the binding is in fact overloaded. That confused the inline-arity computation in `makeCorePair` (#27589). The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`. That actually simplifies the API of `makeCorePair`, which is nice. The first bug is fixed by swapping the visiblity flags in `GHC.Core.Opt.Arity.mkEtaForAllMCo` Getting the INLINE behaviour right led to some perf changes: * Runtime /halved/ on T7954 due to better specialisation * Compile time increased by 6% in T21839c because a bit more inlining happened, as it always should have done. * For some reason compile-time max-bytes-used dropped by 30% on T27336, but only on one build configuration; and it increased on LinkableUsage02 by 6% on another configuration Geometric mean effect on our compile time benchmarks is +0.1%. Metric Decrease: T27336 T7954 Metric Increase: LinkableUsage02 T21839c - - - - - 22 changed files: - + changelog.d/T27557 - + changelog.d/T27589 - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Var.hs - libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr - + testsuite/tests/simplCore/should_compile/T27589.hs - + testsuite/tests/simplCore/should_compile/T27589.stderr - + testsuite/tests/simplCore/should_compile/T27590.hs - + testsuite/tests/simplCore/should_compile/T27590.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T27557.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== changelog.d/T27557 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27577 +mrs: !16433 +synopsis: + Fix a Core Lint error involving RequiredTypeArguments +description: + Fixes an issue with a coercion being used for eta expansion storing + the wrong visibility information, which caused a Core Lint error. ===================================== changelog.d/T27589 ===================================== @@ -0,0 +1,10 @@ +section: compiler +issues: #27589 #27590 +mrs: !16433 +synopsis: + Fixes to arity computations +description: + The arity computation for INLINE pragmas now correctly takes into + account required type arguments. Separately, the arity computation + in ``tcPolyCheck`` now consistently handles dictionary arguments, fixing + a short-cut codepath which didn't ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2370,11 +2370,15 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco | otherwise -> mk_fco (mkRepReflCo ty) MCo co -> mk_fco co where - mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) + mk_fco co = MCo (mkForAllCo tcv coreTyLamForAllTyFlag vis MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] -- in GHC.Core.TyCo.Rep + -- + -- Orientation: remember, the output of mkEtaForAllCo goes into an `EI bs mco`, + -- and is SymCo'd in `etaInfoAbs`. Hence the orientation of the visibility + -- flags. A bit of a brain-strain (#27557). {- ************************************************************************ ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -534,6 +534,13 @@ looks like Note that we must cast `a` by a cv bound in the same type in order to make this work out. +Notice that the corresponding /term/ looks like (Lam a expr): + * If `a` is a type variable, that lambda has no runtime significance; + it is erased + * If `a` is a coercion variable, we pass a (zero-width) runtime argument; + it is not erased +The relevant predicate on the binder is `isRuntimeVar`. + See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2 which gives a general road map that covers this space. Having this feature in Core does *not* mean we have it in source Haskell. See #15710 about that. ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1687,10 +1687,11 @@ isSingletonMatchGroup matches | otherwise = False -matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +matchGroupVisArity :: MatchGroup (GhcPass id) body -> VisArity -- This is called before type checking, when mg_arg_tys is not set -matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] -matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) +-- Returns the "visible arity" of the MatchGroup i.e. including required type arguments. +matchGroupVisArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] +matchGroupVisArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -69,7 +69,7 @@ import GHC.Types.InlinePragma import GHC.Types.Name import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Var( EvVar, mkLocalVar ) +import GHC.Types.Var( EvVar, mkLocalVar, isRuntimePiTyBinder ) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Unique.Set( nonDetEltsUniqSet ) @@ -196,7 +196,7 @@ dsHsBind dflags (VarBind { var_id = var = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here - ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr + ; let core_bind@(id,_) = makeCorePair dflags var False core_expr force_var = if xopt LangExt.Strict dflags then [id] else [] @@ -211,11 +211,11 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun ; let body' = mkOptTickBox tick body rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + core_binds@(id,_) = makeCorePair dflags fun False rhs force_var -- Bindings are strict when -XStrict is enabled | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas + , matchGroupVisArity matches == 0 -- no need to force lambdas = [id] | isBangedHsBind b = [id] @@ -303,7 +303,7 @@ dsAbsBinds dflags tyvars dicts exports ; let global_id' = addIdSpecialisations global_id rules main_bind = makeCorePair dflags global_id' (isDefaultMethod prags) - (dictArity dicts) rhs + rhs ; return (force_vars', fromOL spec_binds ++ [main_bind]) } } @@ -386,7 +386,7 @@ dsAbsBinds dflags tyvars dicts exports mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id `orElse` lcl_id in - makeCorePair dflags lcl_w_inline False 0 rhs + makeCorePair dflags lcl_w_inline False rhs inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with -- the inline pragma from the source @@ -437,9 +437,9 @@ dsAbsBinds dflags tyvars dicts exports -- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` -- using this information. ------------------------ -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr +makeCorePair :: DynFlags -> Id -> Bool -> CoreExpr -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs +makeCorePair dflags gbl_id is_default_method rhs | is_default_method -- Default methods are *always* inlined -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) @@ -456,22 +456,43 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs inline_prag = idInlinePragma gbl_id inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs inline_pair - | AppliedToAtLeast arity <- inlinePragmaSaturation inline_prag + | AppliedToAtLeast vis_arity <- inlinePragmaSaturation inline_prag -- Add an Unfolding for an INLINE (but not for NOINLINE) -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - , let real_arity = dict_arity + arity - -- NB: The arity passed to mkInlineUnfoldingWithArity - -- must take account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs - , etaExpand real_arity rhs) + , let runtime_arity = findSatArity vis_arity (idType gbl_id) + -- NB: runtime_arity: the arity passed to mkInlineUnfoldingWithArity + -- must take account of dictionaries and required type args + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc + runtime_arity rhs + , etaExpand runtime_arity rhs) | otherwise = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts +findSatArity :: VisArity -> Type -> Arity +-- Given the VisArity, find the value Arity of the function. +-- This is the number of runtime-value arguments the function must be applied +-- to before the INLINE pragma fires and inlines the function +-- We must: +-- add one for each invisible dictionary arg; and +-- subtract one for each required type argment +findSatArity vis_arity ty + = go vis_arity pi_bndrs + where + (pi_bndrs, _) = splitPiTys ty + + go vis_arity (bndr : bndrs) + | isInvisiblePiTyBinder bndr = add_bndr bndr (go vis_arity bndrs) + | vis_arity == 0 = 0 + | otherwise = add_bndr bndr (go (vis_arity-1) bndrs) + go vis_arity [] + | vis_arity == 0 = 0 + | otherwise = pprPanic "findSatArity" (ppr vis_arity $$ ppr ty) + + add_bndr :: PiTyBinder -> Arity -> Arity + add_bndr bndr ar | isRuntimePiTyBinder bndr = ar+1 + | otherwise = ar {- Note [Desugaring AbsBinds] ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -737,21 +737,21 @@ Call @match@ with all of this information! -- There are three possible cases for matchWrapper's scrutinees argument: -- -- 1. Nothing Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee --- The MatchGroup may have matchGroupArity of 0 or more. Examples: --- f p1 q1 = ... -- matchGroupArity 2 +-- The MatchGroup may have matchGroupVisArity of 0 or more. Examples: +-- f p1 q1 = ... -- matchGroupVisArity 2 -- f p2 q2 = ... -- -- \cases | g1 -> ... -- matchGroupArity 0 -- | g2 -> ... -- -- 2. Just [e] Used for HsCase, RecordUpd; exactly one scrutinee --- The MatchGroup has matchGroupArity of exactly 1. Example: --- case e of p1 -> e1 -- matchGroupArity 1 +-- The MatchGroup has matchGroupVisArity of exactly 1. Example: +-- case e of p1 -> e1 -- matchGroupVisArity 1 -- p2 -> e2 -- -- 3. Just es Used for HsCmdLamCase; zero or more scrutinees -- The MatchGroup has matchGroupArity of (length es). Example: --- \cases p1 q1 -> returnA -< ... -- matchGroupArity 2 +-- \cases p1 q1 -> returnA -< ... -- matchGroupVisArity 2 -- p2 q2 -> ... matchWrapper ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -288,7 +288,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- We don't want to generate code for blacklisted positions -- We don't want redundant ticks on simple pattern bindings -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = matchGroupArity matches == 0 + let simple = matchGroupVisArity matches == 0 -- A binding is a "simple pattern binding" if it is a -- funbind with zero patterns toplev = null decl_path ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -808,7 +808,7 @@ checkMonomorphismRestriction mbis lbinds restricted (VarBind { var_ext = x }) = dataConCantHappen x restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b) - restricted_match mg = matchGroupArity mg == 0 + restricted_match mg = matchGroupVisArity mg == 0 -- No args => like a pattern binding -- Some args => a function binding ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -599,26 +599,26 @@ mkPragEnv sigs binds Nothing -> sig -- See Note [Pattern synonym inline arity] -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds + ar_env :: NameEnv VisArity + ar_env = foldr lhsBindVisArity emptyNameEnv binds -addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn +addInlinePragArity :: VisArity -> LSig GhcRn -> LSig GhcRn addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl)) addInlinePragArity _ sig = sig -add_inl_arity :: Arity -> InlinePragma GhcRn -> InlinePragma GhcRn +add_inl_arity :: VisArity -> InlinePragma GhcRn -> InlinePragma GhcRn add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec }) | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE = prag `setInlinePragmaSaturation` AppliedToAtLeast ar | otherwise = prag -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind +lhsBindVisArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindVisArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupVisArity ms) +lhsBindVisArity _ env = env -- PatBind/VarBind ----------------- ===================================== compiler/GHC/Types/Arity.hs ===================================== @@ -84,7 +84,14 @@ like Haskell, there is more than one way to count those arguments. forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4 * `VisArity` is the syntactic notion of arity. It is the number of /visible/ - arguments, i.e. arguments that occur visibly in the source code. + arguments, i.e. arguments that occur visibly in the source code. For example: + f1 :: forall a. a -> a + f1 x = x + f2 :: forall a -> a -> a + f2 t x = x + Both have Arity 1 because there is one /value/ argument. + But f1 has VisArity 1 while f2 has VisArity 2, becuase f2 has a required + type argument. In a function call `f x y z`, we can confidently say that f's vis-arity >= 3, simply because we see three arguments [x,y,z]. We write (>=) rather than (==) ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -104,7 +104,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Hs.Extension -import GHC.Types.Arity (Arity) +import GHC.Types.Arity (VisArity) import GHC.Types.SourceText (SourceText(..)) import GHC.Utils.Binary import GHC.Utils.Outputable @@ -125,12 +125,13 @@ infixl 1 `setInlinePragmaActivation`, -- | The arity /at which to/ inline a function. -- This may differ from the function's syntactic arity. data InlineSaturation - = AppliedToAtLeast !Arity + = AppliedToAtLeast !VisArity -- ^ Inline only when applied to @n@ explicit - -- (non-type, non-dictionary) arguments. + -- (required type or value) arguments. -- -- That is, 'AppliedToAtLeast' describes the number of -- *source-code* arguments the thing must be applied to. + | AnySaturation -- ^ There does not exist an explicit number of arguments -- that the inlining process should be applied to. ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -82,7 +82,7 @@ module GHC.Types.Var ( -- * PiTyBinder PiTyBinder(..), PiTyVarBinder, isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder, - isVisiblePiTyBinder, + isVisiblePiTyBinder, isRuntimePiTyBinder, isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, @@ -757,7 +757,12 @@ instance NamedThing tv => NamedThing (VarBndr tv flag) where -- not. See Note [PiTyBinders] data PiTyBinder = Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag - | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy. + -- Erased (not passed at runtime) if the binder is + -- a type variable; not erased if coercion variable + + | Anon (Scaled Type) FunTyFlag -- A term-lambda binder, passing a runtime value + -- The argument can be a constraint (incl dictionary) + -- or an ordinary value -- The arrow is described by the FunTyFlag deriving Data @@ -792,6 +797,12 @@ namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv namedPiTyBinder_maybe _ = Nothing +isRuntimePiTyBinder :: PiTyBinder -> Bool +isRuntimePiTyBinder (Anon {}) = True -- Always passed at runtime +isRuntimePiTyBinder (Named (Bndr tcv _)) = isCoVar tcv + -- isCoVar: see Note [Why ForAllTy can quantify over a coercion variable] + -- and Note [Unused coercion variable in ForAllTy], in GHC.Core.TyCo.Rep + -- | Does this binder bind a variable that is /not/ erased? Returns -- 'True' for anonymous binders. isAnonPiTyBinder :: PiTyBinder -> Bool @@ -817,7 +828,7 @@ piTyBinderType (Named (Bndr tv _)) = varType tv piTyBinderType (Anon ty _) = scaledThing ty {- Note [PiTyBinders] -~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ But a type like forall a. Maybe a -> forall b. (a,b) -> b @@ -830,14 +841,18 @@ argument to a Pi-type. GHC Core currently supports two different Pi-types: * Anon ty1 fun_flag: a non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. + + See wrinkle (PIT1) + + These are lifted to Coercions with the corresponding FunCo. + + * Named (Var tcv forall_flag): a dependent polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty - * Named (Var tv forall_flag) - A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty + See wrinkle (PIT2) Both forms of Pi-types classify terms/types that take an argument. In other words, if `x` is either a function or a polytype, `x arg` makes sense @@ -845,12 +860,16 @@ words, if `x` is either a function or a polytype, `x arg` makes sense Wrinkles -* The Anon constructor of PiTyBinder contains a FunTyFlag. Since +(PIT1) The Anon constructor of PiTyBinder contains a FunTyFlag. Since the PiTyBinder really only describes the /argument/ it should perhaps only have a TypeOrConstraint rather than a full FunTyFlag. But it's very convenient to have the full FunTyFlag, say in mkPiTys, so that's what we do. +(PIT2) The `tcv` in `Named (Var tcv forall_flag) is usually a type variable + but can exceptionally be a coercion variable: see + Note [Why ForAllTy can quantify over a coercion variable]. + If it's a type variable it will be erased; if coercion variable it will not. Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr ===================================== @@ -43,17 +43,17 @@ fusionElemFilter jump go1 eta fusionNotElemConcatMap - = \ x x1 -> + = \ x eta -> joinrec { go1 ds = case ds of { [] -> True; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> jump go1 ys; 1# -> False }; @@ -62,20 +62,20 @@ fusionNotElemConcatMap } } }; } in - jump go1 x1 + jump go1 eta fusionElemConcatMap - = \ x x1 -> + = \ x eta -> joinrec { go1 ds = case ds of { [] -> False; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> jump go1 ys; 1# -> True }; @@ -84,7 +84,7 @@ fusionElemConcatMap } } }; } in - jump go1 x1 + jump go1 eta fusionNotElemMap = \ x eta -> ===================================== libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr ===================================== @@ -77,25 +77,25 @@ fusionElemFilter jump go1 eta fusionNotElemConcatMap - = \ x x1 -> - case x1 of { + = \ x eta -> + case eta of { [] -> True; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> joinrec { go1 ds = case ds of { [] -> True; : y1 ys1 -> - case y1 of { I# x4 -> - case ==# x3 (+# x4 1#) of { + case y1 of { I# x3 -> + case ==# x2 (+# x3 1#) of { __DEFAULT -> - case ==# x3 (+# x4 2#) of { + case ==# x2 (+# x3 2#) of { __DEFAULT -> jump go1 ys1; 1# -> False }; @@ -113,25 +113,25 @@ fusionNotElemConcatMap } fusionElemConcatMap - = \ x x1 -> - case x1 of { + = \ x eta -> + case eta of { [] -> False; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> joinrec { go1 ds = case ds of { [] -> False; : y1 ys1 -> - case y1 of { I# x4 -> - case ==# x3 (+# x4 1#) of { + case y1 of { I# x3 -> + case ==# x2 (+# x3 1#) of { __DEFAULT -> - case ==# x3 (+# x4 2#) of { + case ==# x2 (+# x3 2#) of { __DEFAULT -> jump go1 ys1; 1# -> True }; ===================================== testsuite/tests/simplCore/should_compile/T27589.hs ===================================== @@ -0,0 +1,9 @@ +module T28589 where + +wombat :: Num a => a -> a +{-# INLINE wombat #-} +wombat x = x+x*x + +g :: Num a => [a] -> [a] +g ys = map wombat ys + -- wombat should not inline here ===================================== testsuite/tests/simplCore/should_compile/T27589.stderr ===================================== @@ -0,0 +1,3 @@ +wombat [InlPrag=INLINE (sat-args=1)] :: forall a. Num a => a -> a +wombat + map @a @a (wombat @a $dNum) ys ===================================== testsuite/tests/simplCore/should_compile/T27590.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module Foo where + +wombat :: forall a -> a -> Maybe a +{-# INLINE wombat #-} +wombat t x = Just x + +g y = wombat Int (y+y) + -- wombat /should/ inline here ===================================== testsuite/tests/simplCore/should_compile/T27590.stderr ===================================== @@ -0,0 +1,2 @@ +wombat [InlPrag=INLINE (sat-args=2)] :: forall a -> a -> Maybe a +wombat ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -609,3 +609,5 @@ test('T4081', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-a test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) test('T27296', [], makefile_test, ['T27296']) test('T27296b', [], makefile_test, ['T27296b']) +test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) +test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/typecheck/should_compile/T27557.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module RequiredTypeArgumentsMkSymCo where + +import Data.Kind (Type) + +f :: forall a . forall (b :: Type) -> a -> a +f t = id +{-# INLINE f #-} ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -968,4 +968,4 @@ test('T24464', normal, compile, ['']) test('ExpansionQLIm', normal, compile, ['']) test('T23135', normal, compile, ['']) test('LazyFieldAnnotations', normal, compile, ['']) - +test('T27557', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a0f9a51c1dacc474c7fd128082edd8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a0f9a51c1dacc474c7fd128082edd8… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Cmm: print unreachable blocks under -dppr-debug (#27368)
by Marge Bot (＠marge-bot) 07 Aug '26

07 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0779e12c by Simon Jakobi at 2026-08-07T12:36:11-04:00 Cmm: print unreachable blocks under -dppr-debug (#27368) Unreachable blocks linger in a CmmGraph's block map for most of the Cmm pipeline, but pprCmmGraph only ever printed the blocks reachable from the entry, so dumps looked consistent while the graph was not. Issues like #27368 were hard to debug due to this. pprCmmGraph now appends the stored-but-unreachable blocks under a "// unreachable blocks:" heading when -dppr-debug is on. See Note [unreachable blocks] in GHC.Cmm.Pipeline. Assisted-by: Claude Opus 5 - - - - - 8 changed files: - + changelog.d/T27368-ppr-unreachable-cmm-blocks.md - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/Pipeline.hs - docs/users_guide/debugging.rst - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.cmm - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T Changes: ===================================== changelog.d/T27368-ppr-unreachable-cmm-blocks.md ===================================== @@ -0,0 +1,10 @@ +section: cmm +issues: #27368 +mrs: !16417 +synopsis: + Cmm dumps now show unreachable blocks under ``-dppr-debug`` +description: + Unreachable blocks stay in a Cmm graph's block map for most of the Cmm + pipeline, but ``-ddump-cmm-*`` only ever printed the blocks reachable from + the graph's entry. Adding ``-dppr-debug`` now appends the stored but + unreachable blocks, which makes bugs like #27368 visible in the dumps. ===================================== compiler/GHC/Cmm.hs ===================================== @@ -151,15 +151,28 @@ instance OutputableP Platform CmmGraph where toBlockMap :: CmmGraph -> LabelMap CmmBlock toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body +-- | Print the blocks reachable from the entry, in reverse postorder. +-- +-- Under @-dppr-debug@ the unreachable blocks stored in the graph are appended +-- too. See Note [unreachable blocks] in "GHC.Cmm.Pipeline". pprCmmGraph :: Platform -> CmmGraph -> SDoc pprCmmGraph platform g = text "{" <> text "offset" - $$ nest 2 (vcat $ map (pdoc platform) blocks) + $$ nest 2 (ppr_blocks blocks $$ unreachable) $$ text "}" - where blocks = revPostorder g - -- revPostorder has the side-effect of discarding unreachable code, - -- so pretty-printed Cmm will omit any unreachable blocks. This can - -- sometimes be confusing. + where + ppr_blocks :: [CmmBlock] -> SDoc + ppr_blocks = vcat . map (pdoc platform) + + blocks = revPostorder g + + unreachable = getPprDebug $ \debug -> + if not debug || mapNull dead_blocks + then empty + else text "// unreachable blocks:" + $$ nest 2 (ppr_blocks (mapElems dead_blocks)) + + dead_blocks = foldl' (\bs b -> mapDelete (entryLabel b) bs) (toBlockMap g) blocks revPostorder :: CmmGraph -> [CmmBlock] revPostorder g = {-# SCC "revPostorder" #-} ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -358,6 +358,7 @@ containing junk code. These aren't necessarily a problem, but removing them is good because it might save time in the native code generator later. +To make unreachable blocks visible in -ddump-cmm-* output, add -dppr-debug. -} dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CLabel -> CmmGraph -> IO () ===================================== docs/users_guide/debugging.rst ===================================== @@ -564,6 +564,11 @@ C-\- representation These flags dump various phases of GHC's C-\- pipeline. +Dumps of Cmm graphs print the blocks reachable from the entry, in reverse +post-order. To also show unreachable blocks, which can linger in the graph, +add :ghc-flag:`-dppr-debug`. These blocks are then listed under a +``// unreachable blocks:`` heading. + .. ghc-flag:: -ddump-cmm-verbose-by-proc :shortdesc: Show output from main C-\- pipeline passes (grouped by proc) :type: dynamic @@ -574,9 +579,6 @@ These flags dump various phases of GHC's C-\- pipeline. the chosen backend. Currently only the NCG backends runs additional passes ( :ghc-flag:`-ddump-opt-cmm` ). - Cmm dumps don't include unreachable blocks since we print - blocks in reverse post-order. - .. ghc-flag:: -ddump-cmm-verbose :shortdesc: Write output from main C-\- pipeline passes to files :type: dynamic ===================================== testsuite/tests/cmm/should_compile/Makefile ===================================== @@ -16,3 +16,16 @@ T16930: T23610: '$(TEST_HC)' $(TEST_HC_OPTS) T23610.cmm -S + +# The three seds below, in order: +# 1. Keep only the "Parsed Cmm" dump, since that is the one stage where the +# unreachable block still exists. +# 2. Rewrite goto targets: their label uniques survive -dsuppress-uniques +# (#21310). +# 3. Drop the "// CmmAssign"-style node annotations, which pprNode emits +# only on DEBUG compilers. +T27368-ppr-debug: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug -dsuppress-uniques -dsuppress-ticks T27368-ppr-debug.cmm 2>&1 \ + | sed -n '/^==* Parsed Cmm/,/^ \}\]/p' \ + | sed 's/goto c[0-9A-Za-z]*/goto _lbl_/g' \ + | sed 's| *// Cmm[A-Za-z]*$$||' ===================================== testsuite/tests/cmm/should_compile/T27368-ppr-debug.cmm ===================================== @@ -0,0 +1,19 @@ +#include "Cmm.h" + +// The block "dead" is stored in the graph but no block branches to it, so it +// only shows up in Cmm dumps under -dppr-debug. +testUnreachable (W_ x) +{ + if (x > 0) { + goto live; + } + return (x); + +dead: + x = x + 42; + return (x); + +live: + x = x - 1; + return (x); +} ===================================== testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout ===================================== @@ -0,0 +1,27 @@ +==================== Parsed Cmm ==================== +[testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + _lbl_: + __locVar_::I64 = R1; + if (__locVar_::I64 > 0) goto _lbl_; else goto _lbl_; + _lbl_: + goto _lbl_; + _lbl_: + __locVar_::I64 = __locVar_::I64 - 1; + R1 = __locVar_::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + _lbl_: + goto _lbl_; + _lbl_: + R1 = __locVar_::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + // unreachable blocks: + _lbl_: + __locVar_::I64 = __locVar_::I64 + 42; + R1 = __locVar_::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + } + }] ===================================== testsuite/tests/cmm/should_compile/all.T ===================================== @@ -13,6 +13,11 @@ test('T20725', normal, compile, ['-package ghc']) test('T23610', normal, makefile_test, ['T23610']) test('T24224', [cmm_src, grep_errmsg(r'(F64.*);', [1]), only_ways(['normal'])], compile, ['-no-hs-main -ddump-cmm -dsuppress-all -dsuppress-uniques']) test('T24474', cmm_src, compile, ['-optc-g3']) +# -dppr-debug makes stored-but-unreachable blocks visible in Cmm dumps (#27368). +# Skipped on wordsize(32) targets, where the dump would say I32/P32, and on +# unregisterised builds, which print call targets with an extra load. +test('T27368-ppr-debug', [when(wordsize(32), skip), when(unregisterised(), skip)], + makefile_test, ['T27368-ppr-debug']) test('T24474-cmm-gets-c-opts', cmm_src, compile, ['-optc-DFOO']) test('T24474-cmm-opt-order', cmm_src, compile, ['-optc-DFOO ' '-optCmmP-UFOO ' View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0779e12ce2cd57034aae61dc67e5f62… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0779e12ce2cd57034aae61dc67e5f62… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/torsten.schmits/mwb-26-07/abstract-linkables] 2 commits: WIP Abstract getLinkDeps
by Torsten Schmits (＠torsten.schmits) 07 Aug '26

07 Aug '26

Torsten Schmits pushed to branch wip/torsten.schmits/mwb-26-07/abstract-linkables at Glasgow Haskell Compiler / GHC Commits: c12bd760 by Torsten Schmits at 2026-08-07T17:30:32+02:00 WIP Abstract getLinkDeps - - - - - ff8b945d by Torsten Schmits at 2026-08-07T17:30:32+02:00 WIP Make extra_decls lazy when loading from Binary - - - - - 5 changed files: - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Unit/Module/ModIface.hs Changes: ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -3,6 +3,8 @@ module GHC.Driver.Env.Types ( Hsc(..) , HscEnv(..) + , LinkDeps (..) + , Linkables (..) ) where import GHC.Driver.Errors.Types ( GhcMessage ) @@ -29,6 +31,10 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.IORef import GHC.Driver.Env.KnotVars +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Linker.Types (Linkable, LoaderState) +import GHC.Unit.Types (UnitId, Module) +import GHC.Types.Unique.DSet (UniqDSet) -- | The Hsc monad: Passing an environment and diagnostic state newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage)) @@ -44,6 +50,18 @@ instance ContainsDynFlags HscEnv where instance HasLogger Hsc where getLogger = Hsc $ \e w -> return (hsc_logger e, w) +data LinkDeps = LinkDeps + { ldNeededLinkables :: [Linkable] + , ldAllLinkables :: [Linkable] + , ldNeededUnits :: [UnitId] + , ldAllUnits :: UniqDSet UnitId + } + +data Linkables where + Linkables :: { + linkablesResolve :: SrcSpan -> [Module] -> IO a, + linkablesSelect :: a -> IO LinkDeps + } -> Linkables -- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source @@ -87,6 +105,8 @@ data HscEnv -- ^ target code interpreter (if any) to use for TH and GHCi. -- See Note [Target code interpreter] + , hsc_linkables :: HscEnv -> LoaderState -> IO Linkables + , hsc_plugins :: !Plugins -- ^ Plugins ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -342,6 +342,7 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do , hsc_FC = fc_var , hsc_type_env_vars = emptyKnotVars , hsc_interp = Nothing + , hsc_linkables = linkablesDefault , hsc_unit_env = unit_env , hsc_plugins = emptyPlugins , hsc_hooks = emptyHooks @@ -2880,10 +2881,10 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do -- Take lock for the actual work. (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do - let link_opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required - deps <- getLinkDeps link_opts interp pls srcspan needed_mods + linkables <- hsc_linkables hsc_env hsc_env pls + deps <- linkablesGet linkables srcspan needed_mods -- We update the LinkerState even if the JS interpreter maintains its linker -- state independently to load new objects here. ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -12,6 +12,10 @@ module GHC.Linker.Deps ( LinkDepsOpts (..) , LinkDeps (..) , getLinkDeps + , Linkables (..) + , linkablesGet + , resolveLinkDeps + , selectLinkDeps ) where @@ -42,16 +46,13 @@ import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo import GHC.Iface.Errors.Types -import GHC.Iface.Errors.Ppr import GHC.Utils.Misc import GHC.Unit.Home -import qualified GHC.Unit.Home.Graph as HUG import GHC.Data.Maybe import Control.Applicative import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Foldable (traverse_) import qualified Data.Set as Set @@ -60,11 +61,8 @@ import Data.List (isSuffixOf) import System.FilePath import System.Directory import GHC.Utils.Logger (Logger) -import Control.Monad ((<$!>)) -import GHC.Driver.Env -import {-# SOURCE #-} GHC.Driver.Main -import Data.Time.Clock import GHC.Unit.Home.Graph +import GHC.Driver.Env.Types (Linkables (..), LinkDeps (..)) data LinkDepsOpts = LinkDepsOpts @@ -86,12 +84,9 @@ data LinkDepsOpts = LinkDepsOpts , ldLogger :: !Logger } -data LinkDeps = LinkDeps - { ldNeededLinkables :: [Linkable] - , ldAllLinkables :: [Linkable] - , ldNeededUnits :: [UnitId] - , ldAllUnits :: UniqDSet UnitId - } +linkablesGet :: Linkables -> SrcSpan -> [Module] -> IO LinkDeps +linkablesGet Linkables {..} span mods = + linkablesSelect =<< linkablesResolve span mods -- | Find all the packages and linkables that a set of modules depends on -- @@ -108,14 +103,8 @@ getLinkDeps -> [Module] -- If you need these -> IO LinkDeps -- ... then link these first getLinkDeps opts interp pls span mods = do - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay opts interp span - - withTiming (ldLogger opts) (text "getLinkDeps" <+> brackets (ppr span)) (const ()) $ - get_link_deps opts pls maybe_normal_osuf span mods + linkables <- resolveLinkDeps opts pls span mods + selectLinkDeps opts interp span linkables -- | Determine which parts of a module and its dependencies should be linked -- when resolving external dependencies. @@ -151,7 +140,7 @@ data LinkExternal = } instance Outputable LinkExternal where - ppr LinkExternal {..} = ppr le_module <> brackets (ppr le_details) + ppr LinkExternal {..} = ppr le_module Outputable.<> brackets (ppr le_details) -- | The decision about the linking method used for a given module. data LinkModule = @@ -180,48 +169,31 @@ instance Outputable LinkModule where LinkObjectModule mod _ -> ppr mod LinkByteCodeModule mod _ -> ppr mod <+> brackets (text "BC") --- | Compute the linkables for the given module set's dependencies. --- --- Home modules in make mode are treated separately in a preprocessing step, --- then all the remaining external deps are processed for both modes. --- If bytecode is available, transitive external deps are included, otherwise --- the module's library is linked and processing stops. --- --- The results are split into sets of needed/loaded modules/packages. -get_link_deps - :: LinkDepsOpts - -> LoaderState - -> Maybe FilePath -- replace object suffixes? - -> SrcSpan - -> [Module] - -> IO LinkDeps -get_link_deps opts pls maybe_normal_osuf span mods = do - (link_deps_home, module_deps_external) <- separate_home_deps - link_deps_external <- external_deps opts module_deps_external - let (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) = - classify_deps pls link_deps_home link_deps_external - ldNeededLinkables <- mapM module_linkable needed_modules - pure LinkDeps { - ldNeededLinkables, - ldAllLinkables = loaded_modules ++ ldNeededLinkables, - ldNeededUnits, - ldAllUnits - } +resolveLinkDeps :: + LinkDepsOpts -> + LoaderState -> + SrcSpan -> + [Module] -> + IO ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) +resolveLinkDeps opts pls span mods = + withTiming (ldLogger opts) (text "getLinkDeps" <+> brackets (ppr span)) (const ()) $ do + (link_deps_home, module_deps_external) <- separate_home_deps + link_deps_external <- external_deps opts module_deps_external + pure (classify_deps pls link_deps_home link_deps_external) where mod_graph = ldModuleGraph opts unit_env = ldUnitEnv opts noninteractive = filterOut isInteractiveModule mods - -- Preprocess the dependencies in make mode to remove all home modules, - -- since the transitive dependency closure is already cached for those in - -- the HUG (see MultiLayerModulesTH_* tests for the performance impact). + -- Preprocess the dependencies to remove all home modules, since the + -- transitive dependency closure is already cached for those in the HUG + -- (see MultiLayerModulesTH_* tests for the performance impact). -- - -- Returns the remaining, external, dependencies on the right, which is the - -- entire set for oneshot mode. - separate_home_deps = - if ldOneShotMode opts - then pure ([], LinkExternal LinkAllDeps <$!> noninteractive) - else make_deps + -- Returns the remaining, external, dependencies on the right. + -- This function only supports make mode; oneshot mode (in which the + -- entire dependency set would be treated as external) is not used by + -- this worker and is not supported here. + separate_home_deps = make_deps make_deps = do (dep_ext, mmods) <- unzip <$> mapM get_mod_info all_home_mods @@ -265,6 +237,22 @@ get_link_deps opts pls maybe_normal_osuf span mods = do Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid +select_link_deps + :: LinkDepsOpts + -> Maybe FilePath -- replace object suffixes? + -> SrcSpan + -> ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + -> IO LinkDeps +select_link_deps opts maybe_normal_osuf span (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) = do + ldNeededLinkables <- mapM module_linkable needed_modules + pure LinkDeps { + ldNeededLinkables, + ldAllLinkables = loaded_modules ++ ldNeededLinkables, + ldNeededUnits, + ldAllUnits + } + where + no_obj :: Outputable a => a -> IO b no_obj mod = dieWith opts span $ text "cannot find object file for module" <+> @@ -277,7 +265,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- results. module_linkable = \case LinkHomeModule hmi -> - adjust_linkable (expectJust "getLinkDeps" (homeModLinkable hmi)) + adjust_linkable (expectJust "foo" (homeModLinkable hmi)) LinkObjectModule mod loc -> do findObjectLinkableMaybe mod loc >>= \case @@ -321,6 +309,20 @@ get_link_deps opts pls maybe_normal_osuf span mods = do CoreBindings WholeCoreBindings {wcb_module} -> pprPanic "Unhydrated core bindings" (ppr wcb_module) +selectLinkDeps + :: LinkDepsOpts + -> Interp + -> SrcSpan -- for error messages + -> ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + -> IO LinkDeps -- ... then link these first +selectLinkDeps opts interp span linkables = do + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay opts interp span + select_link_deps opts maybe_normal_osuf span linkables + data LinkDep = LinkModules !(UniqDFM ModuleName LinkModule) | @@ -331,11 +333,6 @@ instance Outputable LinkDep where LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods) LinkLibrary uid -> text "library:" <+> ppr uid -data OneshotError = - NoInterface !MissingInterfaceError - | - LinkBootModule !Module - -- | Compute the transitive dependency closure of the given modules. -- -- Used for all oneshot mode dependencies and for external dependencies of home @@ -346,21 +343,13 @@ external_deps :: [LinkExternal] -> IO [LinkDep] external_deps opts mods = - runExceptT (external_deps_loop opts mods emptyUDFM) >>= \case - Right a -> pure (eltsUDFM a) - Left err -> throwProgramError opts (message err) - where - message = \case - NoInterface err -> - missingInterfaceErrorDiagnostic (ldMsgOpts opts) err - LinkBootModule mod -> - link_boot_mod_error mod + eltsUDFM <$> external_deps_loop opts mods emptyUDFM external_deps_loop :: LinkDepsOpts -> [LinkExternal] -> UniqDFM UnitId LinkDep -> - ExceptT OneshotError IO (UniqDFM UnitId LinkDep) + IO (UniqDFM UnitId LinkDep) external_deps_loop _ [] acc = pure acc external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do @@ -386,8 +375,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do -- link an object file (which happens for home unit modules, since those -- have no libraries). process_module = \case - LinkAllDeps | is_home || package_bc -> try_iface - | otherwise -> add_library + LinkAllDeps -> add_library -- @LinkOnlyPackages@ is used for make mode home modules, so all imports -- that are not external are already processed otherwise. @@ -407,45 +395,9 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do | otherwise = False - -- Load the iface and attempt to get bytecode from Core bindings. - try_iface = - liftIO (ldLoadIface opts load_reason mod) >>= \case - Failed err -> throwE (NoInterface err) - Succeeded (iface, loc) -> do - mb_load_bc <- liftIO (ldLoadByteCode opts (mi_module iface)) - with_iface iface loc mb_load_bc - - -- Decide how to link this module. - -- If bytecode or an object file is available, use those in that order. - -- Otherwise fall back to linking a library. - with_iface iface loc mb_load_bc - | IsBoot <- mi_boot iface - = throwE (LinkBootModule mod) - - | ldUseByteCode opts - , is_home || package_bc - , Just load_bc <- mb_load_bc - = add_module iface (LinkByteCodeModule mod load_bc) "bytecode" - - | is_home - = add_module iface (LinkObjectModule mod loc) "object" - - | otherwise - = add_library - add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [], Just "library") - add_module iface lmod action = - with_deps with_mod iface True action - where - with_mod = alterUDFM (add_package_module lmod) acc mod_unit_id - - add_package_module lmod = \case - Just (LinkLibrary u) -> Just (LinkLibrary u) - Just (LinkModules old) -> Just (LinkModules (addToUDFM old mod_name lmod)) - Nothing -> Just (LinkModules (unitUDFM mod_name lmod)) - with_deps acc iface local action = pure (addListToUDFM acc link, new_local ++ new_package, Just action) where @@ -458,26 +410,17 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do | (_, GWIB m _) <- Set.toList (dep_direct_mods (mi_deps iface)) ] - -- If bytecode linking of external dependencies is enabled, add them to the - -- jobs passed to the next iteration of 'external_deps_loop'. - -- Otherwise, link all package deps as libraries. - package_deps iface - | package_bc - = ([], [LinkExternal LinkAllDeps usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]) - | otherwise - = ([(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) - - load_reason = - text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" - - package_bc = ldPkgByteCode opts - - -- In multiple home unit mode, this only considers modules from the same - -- unit as the splice's module to be eligible for linking bytecode when - -- @-fpackage-db-byte-code@ is off. - -- For make mode, this is irrelevant, since any bytecode from the HUG is - -- obtained directly, not going through 'external_deps'. + -- External package dependencies are always linked as libraries; this + -- worker does not support traversing external package modules for + -- bytecode ("-fpackage-db-byte-code"). + package_deps iface = + ([(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) + + -- Considers only modules from the same unit as the splice's module to be + -- eligible for linking bytecode. + -- For make mode, this is irrelevant for home modules in general, since any + -- bytecode from the HUG is obtained directly, not going through + -- 'external_deps'. is_home | Just home <- ue_homeUnit (ldUnitEnv opts) = homeUnitAsUnit home == mod_unit @@ -489,11 +432,6 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do mod_unit_id = moduleUnitId mod mod_unit = moduleUnit mod -link_boot_mod_error :: Module -> SDoc -link_boot_mod_error mod = - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module" - -- | Split link dependencies into the sets of modules and packages that have -- been linked previously and those that need to be linked now by checking for -- their presence in the 'LoaderState': ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Linker.Loader , rmDupLinkables , modifyLoaderState , initLinkDepsOpts + , linkablesDefault ) where @@ -97,7 +98,6 @@ import Control.Monad import qualified Data.Set as Set import Data.Char (isSpace) import Data.Functor ((<&>)) -import qualified Data.Foldable as Foldable import Data.IORef import Data.List (intercalate, isPrefixOf, nub, partition) import Data.Maybe @@ -115,7 +115,7 @@ import System.Win32.Info (getSystemDirectory) #endif import GHC.Utils.Exception -import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) +import GHC.Unit.Home.Graph (unitEnv_foldWithKey) -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -231,10 +231,10 @@ loadDependencies -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required -- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do - let opts = initLinkDepsOpts hsc_env + linkables <- hsc_linkables hsc_env hsc_env pls -- Find what packages and linkables are required - deps <- getLinkDeps opts interp pls span needed_mods + deps <- linkablesGet linkables span needed_mods let this_pkgs_needed = ldAllUnits deps @@ -683,6 +683,15 @@ initLinkDepsOpts hsc_env = opts EPS {eps_iface_bytecode} <- hscEPS hsc_env pure (lookupModuleEnv eps_iface_bytecode mod) +linkablesDefault :: + HscEnv -> + LoaderState -> + IO Linkables +linkablesDefault hsc_env pls = + pure Linkables { + linkablesResolve = getLinkDeps (initLinkDepsOpts hsc_env) (hscInterp hsc_env) pls, + linkablesSelect = pure + } {- ********************************************************************** ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -503,7 +503,7 @@ instance Binary ModIface where lazyPut bh warns lazyPut bh anns put_ bh decls - put_ bh extra_decls + lazyPut bh extra_decls put_ bh foreign_ put_ bh insts put_ bh fam_insts @@ -536,7 +536,7 @@ instance Binary ModIface where warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh - extra_decls <- get bh + extra_decls <- lazyGet bh foreign_ <- get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9101dbb234d2cff453d93dec15ccf2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9101dbb234d2cff453d93dec15ccf2… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/ci-stages] chore: reorder packaging and testing stages
by Magnus (＠MangoIV) 07 Aug '26

07 Aug '26

Magnus pushed to branch wip/mangoiv/ci-stages at Glasgow Haskell Compiler / GHC Commits: 2a21b2e0 by mangoiv at 2026-08-07T16:54:12+02:00 chore: reorder packaging and testing stages - - - - - 3 changed files: - .gitlab-ci.yml - + flake.lock - + flake.nix Changes: ===================================== .gitlab-ci.yml ===================================== @@ -68,8 +68,8 @@ stages: - tool-lint # Source linting of the tools - quick-build # A very quick smoke-test to weed out broken commits - full-build # Build all the things - - packaging # Source distribution, etc. - testing # head.hackage correctness and compiler performance testing + - packaging # Source distribution, etc. - deploy # push documentation # Note [The CI Story] ===================================== flake.lock ===================================== @@ -0,0 +1,61 @@ +{ + "nodes": { + "flake-parts": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib" + }, + "locked": { + "lastModified": 1778716662, + "narHash": "sha256-m1Yf0wZ8j1OHjTc2UwHwyQRSnNeSgLJOd7q5Y45hzi4=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "f7c1a2d347e4c52d5fb8d10cb4d94b5884e546fb", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1781607440, + "narHash": "sha256-rxO+uc/KFbSJp+pgyXRuAX6QlG9hJdnt0BXpEQRXY+U=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "3e41b24abd260e8f71dbe2f5737d24122f972158", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib": { + "locked": { + "lastModified": 1777168982, + "narHash": "sha256-GOkGPcboWE9BmGCRMLX3worL4EMnsnG8MyKmXNeYuhQ=", + "owner": "nix-community", + "repo": "nixpkgs.lib", + "rev": "f5901329dade4a6ea039af1433fb087bd9c1fe14", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "nixpkgs.lib", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-parts": "flake-parts", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} ===================================== flake.nix ===================================== @@ -0,0 +1,41 @@ +{ + inputs = { + flake-parts.url = "github:hercules-ci/flake-parts"; + nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; + }; + + outputs = inputs: + inputs.flake-parts.lib.mkFlake {inherit inputs;} { + systems = ["x86_64-linux" "aarch64-linux"]; + perSystem = { + config, + pkgs, + ... + }: { + devShells.default = pkgs.mkShell { + nativeBuildInputs = [ + pkgs.haskell.compiler.ghc910 + pkgs.haskell.packages.ghc910.haskell-language-server + pkgs.haskellPackages.happy + pkgs.haskellPackages.alex + pkgs.cabal-install + pkgs.autoconf + pkgs.mold + pkgs.automake + pkgs.m4 + pkgs.python3 + pkgs.less + pkgs.llvmPackages_20.llvm + pkgs.llvmPackages_20.clang + pkgs.gmp + pkgs.sphinx + (pkgs.texliveSmall.withPackages (ps: with ps; [termes-otf + scheme-medium collection-xetex fncychap titlesec tabulary varwidth + framed capt-of wrapfig needspace dejavu-otf helvetic upquote + ])) + ]; + }; + }; + flake = {}; + }; +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a21b2e051a60d9cdeb1f86a077b412… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a21b2e051a60d9cdeb1f86a077b412… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0