INLINE pragma for patterns (#12178)

Allow INLINE and NOINLINE pragmas to be used for patterns.
Those are applied to both the builder and matcher (where applicable).

3 files changed, 55 insertions, 18 deletions

diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 896ded667b..178390192f 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -445,10 +445,10 @@ tc_single :: forall thing.
             TopLevelFlag -> TcSigFun -> TcPragEnv
           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
           -> TcM (LHsBinds GhcTc, thing)
-tc_single _top_lvl sig_fn _prag_fn
+tc_single _top_lvl sig_fn prag_fn
           (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
           _ thing_inside
-  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) prag_fn
        ; thing <- setGblEnv tcg_env thing_inside
        ; return (aux_binds, thing)
        }
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index ae9dd613d3..0a0b3f3bad 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -26,7 +26,7 @@ import GHC.Core.Multiplicity
 import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )
 import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
 import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId )
+import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags )
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Zonk
@@ -77,12 +77,13 @@ import Data.List( partition, mapAccumL )
 
 tcPatSynDecl :: PatSynBind GhcRn GhcRn
              -> Maybe TcSigInfo
+             -> TcPragEnv -- See Note [Pragmas for pattern synonyms]
              -> TcM (LHsBinds GhcTc, TcGblEnv)
-tcPatSynDecl psb mb_sig
+tcPatSynDecl psb mb_sig prag_fn
   = recoverM (recoverPSB psb) $
     case mb_sig of
-      Nothing                 -> tcInferPatSynDecl psb
-      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
+      Nothing                 -> tcInferPatSynDecl psb prag_fn
+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn
       _                       -> panic "tcPatSynDecl"
 
 recoverPSB :: PatSynBind GhcRn GhcRn
@@ -139,9 +140,11 @@ pattern.) But it'll do for now.
 -}
 
 tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
+                  -> TcPragEnv
                   -> TcM (LHsBinds GhcTc, TcGblEnv)
 tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
                        , psb_def = lpat, psb_dir = dir })
+                  prag_fn
   = addPatSynCtxt lname $
     do { traceTc "tcInferPatSynDecl {" $ ppr name
 
@@ -186,7 +189,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
 
        ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
        ; rec_fields <- lookupConstructorFields name
-       ; tc_patsyn_finish lname dir is_infix lpat'
+       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn
                           (mkTyVarBinders InferredSpec univ_tvs
                             , req_theta,  ev_binds, req_dicts)
                           (mkTyVarBinders InferredSpec ex_tvs
@@ -344,6 +347,7 @@ is not very helpful, but at least we don't get a Lint error.
 
 tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
                   -> TcPatSynInfo
+                  -> TcPragEnv
                   -> TcM (LHsBinds GhcTc, TcGblEnv)
 tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                          , psb_def = lpat, psb_dir = dir }
@@ -351,6 +355,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                       , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req  = req_theta
                       , patsig_ex_bndrs   = explicit_ex_bndrs,   patsig_prov = prov_theta
                       , patsig_body_ty    = sig_body_ty }
+                  prag_fn
   = addPatSynCtxt lname $
     do { traceTc "tcCheckPatSynDecl" $
          vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta
@@ -443,7 +448,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        ; traceTc "tcCheckPatSynDecl }" $ ppr name
 
        ; rec_fields <- lookupConstructorFields name
-       ; tc_patsyn_finish lname dir is_infix lpat'
+       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn
                           (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
                           (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
                           (args', skol_arg_tys)
@@ -653,6 +658,7 @@ tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                  -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                  -> Bool              -- ^ Whether infix
                  -> LPat GhcTc        -- ^ Pattern of the PatSyn
+                 -> TcPragEnv
                  -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])
                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
                  -> ([LHsExpr GhcTc], [TcType])  -- ^ Pattern arguments and types
@@ -660,7 +666,7 @@ tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                  -> [FieldLabel]      -- ^ Selector names
                  -- ^ Whether fields, empty if not record PatSyn
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
-tc_patsyn_finish lname dir is_infix lpat'
+tc_patsyn_finish lname dir is_infix lpat' prag_fn
                  (univ_tvs, req_theta, req_ev_binds, req_dicts)
                  (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
                  (args, arg_tys)
@@ -691,7 +697,7 @@ tc_patsyn_finish lname dir is_infix lpat'
            ppr pat_ty
 
        -- Make the 'matcher'
-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn
                                          (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
                                          (args, arg_tys)
@@ -701,7 +707,7 @@ tc_patsyn_finish lname dir is_infix lpat'
        ; builder_id <- mkPatSynBuilderId dir lname
                                          univ_tvs req_theta
                                          ex_tvs   prov_theta
-                                         arg_tys pat_ty
+                                         arg_tys pat_ty prag_fn
 
        -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
@@ -731,13 +737,14 @@ tc_patsyn_finish lname dir is_infix lpat'
 
 tcPatSynMatcher :: Located Name
                 -> LPat GhcTc
+                -> TcPragEnv
                 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                 -> ([LHsExpr GhcTc], [TcType])
                 -> TcType
                 -> TcM ((Id, Bool), LHsBinds GhcTc)
 -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-tcPatSynMatcher (L loc name) lpat
+tcPatSynMatcher (L loc 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
@@ -800,17 +807,19 @@ tcPatSynMatcher (L loc name) lpat
                     , mg_ext = MatchGroupTc [] res_ty
                     , mg_origin = Generated
                     }
+             prags = lookupPragEnv prag_fn name
+             -- See Note [Pragmas for pattern synonyms]
 
-       ; let bind = FunBind{ fun_id = L loc matcher_id
+       ; matcher_prag_id <- addInlinePrags matcher_id prags
+       ; let bind = FunBind{ fun_id = L loc matcher_prag_id
                            , fun_matches = mg
                            , fun_ext = idHsWrapper
                            , fun_tick = [] }
              matcher_bind = unitBag (noLoc bind)
-
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
 
-       ; return ((matcher_id, is_unlifted), matcher_bind) }
+       ; return ((matcher_prag_id, is_unlifted), matcher_bind) }
 
 mkPatSynRecSelBinds :: PatSyn
                     -> [FieldLabel]  -- ^ Visible field labels
@@ -836,10 +845,11 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                   -> [InvisTVBinder] -> ThetaType
                   -> [InvisTVBinder] -> ThetaType
                   -> [Type] -> Type
+                  -> TcPragEnv
                   -> TcM (Maybe (Id, Bool))
 mkPatSynBuilderId dir (L _ name)
                   univ_bndrs req_theta ex_bndrs prov_theta
-                  arg_tys pat_ty
+                  arg_tys pat_ty prag_fn
   | isUnidirectional dir
   = return Nothing
   | otherwise
@@ -856,8 +866,11 @@ mkPatSynBuilderId dir (L _ name)
               -- See Note [Exported LocalIds] in GHC.Types.Id
 
              builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
+             prags          = lookupPragEnv prag_fn name
+             -- See Note [Pragmas for pattern synonyms]
 
-       ; return (Just (builder_id', need_dummy_arg)) }
+       ; builder_prag_id <- addInlinePrags builder_id' prags
+       ; return (Just (builder_prag_id, need_dummy_arg)) }
 
 tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
                     -> TcM (LHsBinds GhcTc)
@@ -1129,12 +1142,34 @@ converting the pattern to an expression (for the builder RHS) we
 simply discard the signature.
 
 Note [Record PatSyn Desugaring]
--------------------------------
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It is important that prov_theta comes before req_theta as this ordering is used
 when desugaring record pattern synonym updates.
 
 Any change to this ordering should make sure to change GHC.HsToCore.Expr if you
 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.
+(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:
+    pattern HeadC x <- x:xs where
+      HeadC x = [x]
+      -- This wouldn't compile: {-# INLINE HeadC #-}
+    {-# INLINE HeadC #-} -- But this works
+
+When no pragma is provided for a pattern, the inlining decision might change
+between different versions of GHC.
  -}
 
 
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
index 38fc4b52f1..22e5c9fb86 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
@@ -5,9 +5,11 @@ import GHC.Tc.Types ( TcM, TcSigInfo )
 import GHC.Tc.Utils.Monad ( TcGblEnv)
 import GHC.Hs.Extension ( GhcRn, GhcTc )
 import Data.Maybe  ( Maybe )
+import GHC.Tc.Gen.Sig ( TcPragEnv )
 
 tcPatSynDecl :: PatSynBind GhcRn GhcRn
              -> Maybe TcSigInfo
+             -> TcPragEnv
              -> TcM (LHsBinds GhcTc, TcGblEnv)
 
 tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)