Add arity to the INLINE pragmas for pattern synonymswip/T21531

The lack of INLNE arity was exposed by #21531.  The fix is
simple enough, if a bit clumsy.

5 files changed, 214 insertions, 34 deletions

diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 971a47bb99..874870765f 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -21,7 +21,8 @@ module GHC.Tc.Gen.Sig(
        tcInstSig,
 
        TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
-       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags
+       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
+       addInlinePrags, addInlinePragArity
    ) where
 
 import GHC.Prelude
@@ -66,7 +67,6 @@ import GHC.Unit.Module( getModule )
 import GHC.Utils.Misc as Utils ( singleton )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Utils.Trace
 
 import GHC.Data.Maybe( orElse )
 
@@ -577,29 +577,32 @@ mkPragEnv sigs binds
     prs = mapMaybe get_sig sigs
 
     get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
-    get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))
-      = Just (nm, L l $ SpecSig   x lnm ty (add_arity nm inl))
-    get_sig (L l (InlineSig x lnm@(L _ nm) inl))
-      = Just (nm, L l $ InlineSig x lnm    (add_arity nm inl))
-    get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
-      = Just (nm, L l $ SCCFunSig x st lnm str)
+    get_sig sig@(L _ (SpecSig _ (L _ nm) _ _))   = Just (nm, add_arity nm sig)
+    get_sig sig@(L _ (InlineSig _ (L _ nm) _))   = Just (nm, add_arity nm sig)
+    get_sig sig@(L _ (SCCFunSig _ _ (L _ nm) _)) = Just (nm, sig)
     get_sig _ = Nothing
 
-    add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function
-      | isInlinePragma inl_prag
-        -- add arity only for real INLINE pragmas, not INLINABLE
+    add_arity n sig  -- Adjust inl_sat field to match visible arity of function
       = case lookupNameEnv ar_env n of
-          Just ar -> inl_prag { inl_sat = Just ar }
-          Nothing -> warnPprTrace True "mkPragEnv no arity" (ppr n) $
-                     -- There really should be a binding for every INLINE pragma
-                     inl_prag
-      | otherwise
-      = inl_prag
+          Just ar -> addInlinePragArity ar sig
+          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
 
+addInlinePragArity :: Arity -> 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 _ sig = sig
+
+add_inl_arity :: Arity -> InlinePragma -> InlinePragma
+add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec })
+  | Inline {} <- inl_spec  -- Add arity only for real INLINE pragmas, not INLINABLE
+  = prag { inl_sat = Just 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)
@@ -638,6 +641,25 @@ addInlinePrags poly_id prags_for_me
     pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)
 
 
+{- Note [Pattern synonym inline arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    {-# INLINE P #-}
+    pattern P x = (x, True)
+
+The INLINE pragma attaches to both the /matcher/ and the /builder/ for
+the pattern synonym; see Note [Pragmas for pattern synonyms] in
+GHC.Tc.TyCl.PatSyn.  But they have different inline arities (i.e. number
+of binders to which we apply the function before inlining), and we don't
+know what those arities are yet.  So for pattern synonyms we don't set
+the inl_sat field yet; instead we do so (via addInlinePragArity) in
+GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind.
+
+It's a bit messy that we set the arities in different ways.  Perhaps we
+should add the arity later for all binders.  But it works fine like this.
+-}
+
+
 {- *********************************************************************
 *                                                                      *
                    SPECIALISE pragmas
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 45810f5d9f..a306a3967e 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -27,7 +27,8 @@ import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy
 import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
 import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags )
+import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv
+                      , addInlinePrags, addInlinePragArity )
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Zonk
@@ -782,7 +783,7 @@ tcPatSynMatcher :: LocatedN Name
                 -> TcType
                 -> TcM (PatSynMatcher, LHsBinds GhcTc)
 -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-tcPatSynMatcher (L loc name) lpat prag_fn
+tcPatSynMatcher (L loc ps_name) lpat prag_fn
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_tys, prov_theta, prov_dicts)
                 (args, arg_tys) pat_ty
@@ -802,7 +803,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
 
              fail_ty  = mkVisFunTyMany unboxedUnitTy res_ty
 
-       ; matcher_name <- newImplicitBinder name mkMatcherOcc
+       ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc
        ; scrutinee    <- newSysLocalId (fsLit "scrut") Many pat_ty
        ; cont         <- newSysLocalId (fsLit "cont")  Many cont_ty
        ; fail         <- newSysLocalId (fsLit "fail")  Many fail_ty
@@ -811,7 +812,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
-             patsyn_id     = mkExportedVanillaId name matcher_sigma
+             patsyn_id     = mkExportedVanillaId ps_name matcher_sigma
                              -- See Note [Exported LocalIds] in GHC.Types.Id
 
              inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
@@ -848,16 +849,21 @@ tcPatSynMatcher (L loc name) lpat prag_fn
                     , mg_ext = MatchGroupTc [] res_ty
                     , mg_origin = Generated
                     }
-             prags = lookupPragEnv prag_fn name
+             matcher_arity = length req_theta + 3
              -- See Note [Pragmas for pattern synonyms]
 
-       ; matcher_prag_id <- addInlinePrags matcher_id prags
+       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
+       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name
+       ; matcher_prag_id <- addInlinePrags matcher_id              $
+                            map (addInlinePragArity matcher_arity) $
+                            lookupPragEnv prag_fn ps_name
+
        ; let bind = FunBind{ fun_id = L loc matcher_prag_id
                            , fun_matches = mg
                            , fun_ext = idHsWrapper
                            , fun_tick = [] }
              matcher_bind = unitBag (noLocA bind)
-       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
+       ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id))
        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
 
        ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }
@@ -905,6 +911,7 @@ mkPatSynBuilder dir (L _ name)
                               mkPhiTy theta $
                               mkVisFunTysMany arg_tys $
                               pat_ty
+
        ; return (Just (builder_name, builder_sigma, need_dummy_arg)) }
 
 tcPatSynBuilderBind :: TcPragEnv
@@ -937,11 +944,17 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
     do { -- Bidirectional, so patSynBuilder returns Just
          let builder_id = mkExportedVanillaId builder_name builder_ty
                          -- See Note [Exported LocalIds] in GHC.Types.Id
-             prags = lookupPragEnv prag_fn ps_name
-             -- See Note [Pragmas for pattern synonyms]
-             -- Keyed by the PatSyn Name, not the (internal) builder name
 
-       ; builder_id <- addInlinePrags builder_id prags
+             (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn
+             builder_arity = length req_theta + length prov_theta
+                             + length arg_tys
+                             + (if need_dummy_arg then 1 else 0)
+
+       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
+       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name
+       ; builder_id <- addInlinePrags builder_id              $
+                       map (addInlinePragArity builder_arity) $
+                       lookupPragEnv prag_fn ps_name
 
        ; let match_group' | need_dummy_arg = add_dummy_arg match_group
                           | otherwise      = match_group
@@ -955,8 +968,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
 
        ; traceTc "tcPatSynBuilderBind {" $
          vcat [ ppr patsyn
-              , ppr builder_id <+> dcolon <+> ppr (idType builder_id)
-              , ppr prags ]
+              , ppr builder_id <+> dcolon <+> ppr (idType builder_id) ]
        ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind)
        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
        ; return builder_binds } } }
@@ -1216,18 +1228,19 @@ want to avoid difficult to decipher core lint errors!
 
 Note [Pragmas for pattern synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-INLINE and NOINLINE pragmas are supported for pattern synonyms. They affect both
-the matcher and the builder.
+INLINE and NOINLINE pragmas are supported for pattern synonyms.
+They affect both the matcher and the builder.
 (See Note [Matchers and builders for pattern synonyms] in PatSyn)
 
 For example:
     pattern InlinedPattern x = [x]
     {-# INLINE InlinedPattern #-}
+
     pattern NonInlinedPattern x = [x]
     {-# NOINLINE NonInlinedPattern #-}
 
-For pattern synonyms with explicit builders, only pragma for the entire pattern
-synonym is supported. For example:
+For pattern synonyms with explicit builders, only a pragma for the
+entire pattern synonym is supported. For example:
     pattern HeadC x <- x:xs where
       HeadC x = [x]
       -- This wouldn't compile: {-# INLINE HeadC #-}
@@ -1235,6 +1248,14 @@ 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.
  -}
 
 
diff --git a/testsuite/tests/patsyn/should_compile/T21531.hs b/testsuite/tests/patsyn/should_compile/T21531.hs
new file mode 100644
index 0000000000..0e453c3c55
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T21531.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T21531 where
+
+import Foreign.C( CChar )
+
+newtype LGate = LGate CChar
+
+{-# INLINE And #-}
+pattern And :: LGate
+pattern And <- LGate 0b00000000
+  where
+    And = LGate 0b00000000
diff --git a/testsuite/tests/patsyn/should_compile/T21531.stderr b/testsuite/tests/patsyn/should_compile/T21531.stderr
new file mode 100644
index 0000000000..7f62943b34
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T21531.stderr
@@ -0,0 +1,123 @@
+
+==================== Desugar (after optimization) ====================
+Result size of Desugar (after optimization)
+  = {terms: 61, types: 30, coercions: 3, joins: 0/0}
+
+-- RHS size: {terms: 19, types: 11, coercions: 1, joins: 0/0}
+T21531.$mAnd [InlPrag=INLINE (sat-args=3)]
+  :: forall {rep :: GHC.Types.RuntimeRep} {r :: TYPE rep}.
+     LGate -> ((# #) -> r) -> ((# #) -> r) -> r
+[LclIdX,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=3,unsat_ok=False,boring_ok=False)
+         Tmpl= \ (@(rep_a18L :: GHC.Types.RuntimeRep))
+                 (@(r_a18M :: TYPE rep_a18L))
+                 (scrut_a18O [Occ=Once1] :: LGate)
+                 (cont_a18P [Occ=Once1!] :: (# #) -> r_a18M)
+                 (fail_a18Q [Occ=Once1!] :: (# #) -> r_a18M) ->
+                 case ==
+                        @CChar
+                        Foreign.C.Types.$fEqCChar
+                        (scrut_a18O `cast` (T21531.N:LGate[0] :: LGate ~R# CChar))
+                        (fromInteger
+                           @CChar Foreign.C.Types.$fNumCChar (GHC.Num.Integer.IS 0#))
+                 of {
+                   False -> fail_a18Q GHC.Prim.void#;
+                   True -> cont_a18P GHC.Prim.void#
+                 }}]
+T21531.$mAnd
+  = \ (@(rep_a18L :: GHC.Types.RuntimeRep))
+      (@(r_a18M :: TYPE rep_a18L))
+      (scrut_a18O :: LGate)
+      (cont_a18P :: (# #) -> r_a18M)
+      (fail_a18Q :: (# #) -> r_a18M) ->
+      case ==
+             @CChar
+             Foreign.C.Types.$fEqCChar
+             (scrut_a18O `cast` (T21531.N:LGate[0] :: LGate ~R# CChar))
+             (fromInteger
+                @CChar Foreign.C.Types.$fNumCChar (GHC.Num.Integer.IS 0#))
+      of {
+        False -> fail_a18Q GHC.Prim.void#;
+        True -> cont_a18P GHC.Prim.void#
+      }
+
+-- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0}
+T21531.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 80 10}]
+T21531.$trModule
+  = GHC.Types.Module
+      (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T21531"#)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep_a19g [InlPrag=[~]] :: GHC.Types.KindRep
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$krep_a19g
+  = GHC.Types.KindRepTyConApp
+      Foreign.C.Types.$tcCChar (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 8, types: 0, coercions: 0, joins: 0/0}
+T21531.$tcLGate :: GHC.Types.TyCon
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 10}]
+T21531.$tcLGate
+  = GHC.Types.TyCon
+      1751240159874500841##64
+      16519490186165952419##64
+      T21531.$trModule
+      (GHC.Types.TrNameS "LGate"#)
+      0#
+      GHC.Types.krep$*
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep_a19h [InlPrag=[~]] :: GHC.Types.KindRep
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$krep_a19h
+  = GHC.Types.KindRepTyConApp
+      T21531.$tcLGate (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep_a19f [InlPrag=[~]] :: GHC.Types.KindRep
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$krep_a19f = GHC.Types.KindRepFun $krep_a19g $krep_a19h
+
+-- RHS size: {terms: 8, types: 0, coercions: 0, joins: 0/0}
+T21531.$tc'LGate :: GHC.Types.TyCon
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 10}]
+T21531.$tc'LGate
+  = GHC.Types.TyCon
+      4309544208860551001##64
+      1328337796258811871##64
+      T21531.$trModule
+      (GHC.Types.TrNameS "'LGate"#)
+      0#
+      $krep_a19f
+
+-- RHS size: {terms: 4, types: 1, coercions: 2, joins: 0/0}
+T21531.$bAnd [InlPrag=INLINE (sat-args=0)] :: LGate
+[LclIdX,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=False, ConLike=False,
+         WorkFree=False, Expandable=False,
+         Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=True)
+         Tmpl= (fromInteger
+                  @CChar Foreign.C.Types.$fNumCChar (GHC.Num.Integer.IS 0#))
+               `cast` (Sym (T21531.N:LGate[0]) :: CChar ~R# LGate)}]
+T21531.$bAnd
+  = (fromInteger
+       @CChar Foreign.C.Types.$fNumCChar (GHC.Num.Integer.IS 0#))
+    `cast` (Sym (T21531.N:LGate[0]) :: CChar ~R# LGate)
+
+
+
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 479b5b0683..e8da69d553 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -81,3 +81,4 @@ test('T16682', [extra_files(['T16682.hs', 'T16682a.hs'])],
                multimod_compile, ['T16682', '-v0 -fwarn-incomplete-patterns -fno-code'])
 test('T17775-singleton', normal, compile, [''])
 test('T14630', normal, compile, ['-Wname-shadowing'])
+test('T21531', [ grep_errmsg(r'INLINE') ], compile, ['-ddump-ds'])