GitLab

Simon Peyton Jones pushed to branch wip/T27744 at Glasgow Haskell Compiler / GHC

Commits:

2ae64e52

by Simon Peyton Jones at 2026-08-27T19:50:27+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`!

4 changed files:

+ changelog.d/T27744
compiler/GHC/Tc/TyCl/PatSyn.hs
+ testsuite/tests/patsyn/should_compile/T27744.hs
testsuite/tests/patsyn/should_compile/all.T

Changes:

changelog.d/T27744

 +section: compiler
 +synopsis: Fixes a bug in arity computation for INLINE pattern synonyms, which led to a compiler crash
 +issues: #27744
 +mrs: !16602

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
 +  later by `GHC.HsToCore.Binds.makeCorePair`. 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

 +{-# 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, [''])