Simon Peyton Jones pushed to branch wip/T27744 at Glasgow Haskell Compiler / GHC Commits: a583c921 by Simon Peyton Jones at 2026-08-26T20:35:40+01:00 Fix buglet in INLINE-arity calculation for pattern synonyms This fixes #27744. The buglet was accidentally introduced by commit 3a0f9a51c1dacc474c7fd128082edd8bf4081256 Author: Simon Peyton Jones <simon.peytonjones@gmail.com> Date: Sat Aug 1 00:13:02 2026 +0100 Fix three bugs related to required type args and INLINE pragmas I failed to find all the calls to `addInlinePragArity`! - - - - - 3 changed files: - compiler/GHC/Tc/TyCl/PatSyn.hs - + testsuite/tests/patsyn/should_compile/T27744.hs - testsuite/tests/patsyn/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -875,8 +875,9 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn mg = MG{ mg_alts = L (l2l $ getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty gen } - matcher_arity = length req_theta + 3 - -- See Note [Pragmas for pattern synonyms] + + matcher_arity :: VisArity -- VisArity excludes dictionary arguments! + matcher_arity = 3 -- See Note [Pragmas for pattern synonyms] -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms] -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name @@ -967,9 +968,8 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) let builder_id = mkExportedVanillaId builder_name builder_ty -- See Note [Exported LocalIds] in GHC.Types.Id - (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn - builder_arity = length req_theta + length prov_theta - + length arg_tys + builder_arity :: VisArity -- VisArity excludes dictionary arguments! + builder_arity = length (patSynArgs patsyn) + (if need_dummy_arg then 1 else 0) -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms] @@ -1348,13 +1348,20 @@ entire pattern synonym is supported. For example: When no pragma is provided for a pattern, the inlining decision might change between different versions of GHC. -Implementation notes. The prag_fn passed in to tcPatSynDecl will have a binding -for the /pattern synonym/ Name, thus - InlinedPattern :-> INLINE -From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher) -and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/ -Name in the prag_fn, and then using addInlinePragArity to add the right -inl_sat field to that INLINE pragma for the matcher or builder respectively. +Implementation notes. + +* The prag_fn passed in to tcPatSynDecl will have a binding + for the /pattern synonym/ Name, thus + InlinedPattern :-> INLINE + From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher) + and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/ + Name in the prag_fn, and then using `addInlinePragArity` to add the right + inl_sat field to that INLINE pragma for the matcher or builder respectively. + +* Note that the arity passed to `addInlinePragArity` is the `VisArity`, the /visible/ + arity. That specifically /excludes/ dictionary arguments, which are dealt with by + `addInlinePragArity`. The builder and matcher have no Required type args, so we + don't need to worry about them in the `VisArity`. -} ===================================== testsuite/tests/patsyn/should_compile/T27744.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE ViewPatterns #-} + +-- | A facility for faking GADTs that work sufficiently similarly +-- to unary natural numbers. +module T27744 + ( Nattish (Zeroy, Succy) + ) + where +import Unsafe.Coerce (unsafeCoerce) +import Data.Kind (Type) + +type Nattish :: forall k. k -> (k -> k) -> k -> Type +newtype Nattish zero succ n = Nattish Word +type role Nattish nominal nominal nominal + +data Res zero succ n where + ResZero :: Res zero succ zero + ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n) + +check :: Nattish zero succ n -> Res zero succ n +check (Nattish 0) = unsafeCoerce ResZero +check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1)) + +pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n +pattern Zeroy <- (check -> ResZero) + where + Zeroy = Nattish 0 +{-# INLINE Zeroy #-} + +pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n +pattern Succy n <- (check -> ResSucc n) + where + Succy (Nattish n) = Nattish (n + 1) +{-# INLINE Succy #-} + +{-# COMPLETE Zeroy, Succy #-} ===================================== testsuite/tests/patsyn/should_compile/all.T ===================================== @@ -94,3 +94,4 @@ test('T26331a', normal, compile, ['']) test('T27440a', normal, compile, ['']) test('T27440b', normal, compile, ['']) test('T27440c', normal, compile, ['']) +test('T27744', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a583c921f39dfde1738fe3dd32bb5e88... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a583c921f39dfde1738fe3dd32bb5e88... 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