Commit d2bbfe52 authored by cgibbard's avatar cgibbard Committed by cgibbard

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).
parent a1a75aa9
......@@ -476,6 +476,23 @@ Ambiguity:
the -XTransformListComp extension.
-}
{- Note [%shift: activation -> {- empty -}]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Context:
sigdecl -> '{-# INLINE' . activation qvarcon '#-}'
activation -> {- empty -}
activation -> explicit_activation
Example:
{-# INLINE [0] Something #-}
Ambiguity:
We don't know whether the '[' is the start of the activation or the beginning
of the [] data constructor.
We parse this as having '[0]' activation for inlining 'Something', rather than
empty activation and inlining '[0] Something'.
-}
{- Note [Parser API Annotations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1605,6 +1622,10 @@ pattern_synonym_sig :: { LSig GhcPs }
{% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) $4)
[mj AnnPattern $1, mu AnnDcolon $3] }
qvarcon :: { Located RdrName }
: qvar { $1 }
| qcon { $1 }
-----------------------------------------------------------------------------
-- Nested declarations
......@@ -2504,7 +2525,7 @@ sigdecl :: { LHsDecl GhcPs }
([ mo $1 ] ++ dcolon ++ [mc $4]) }
-- This rule is for both INLINE and INLINABLE pragmas
| '{-# INLINE' activation qvar '#-}'
| '{-# INLINE' activation qvarcon '#-}'
{% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3
(mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
(snd $2)))))
......@@ -2544,7 +2565,8 @@ sigdecl :: { LHsDecl GhcPs }
[mo $1,mc $3] }
activation :: { ([AddAnn],Maybe Activation) }
: {- empty -} { ([],Nothing) }
: -- See Note [%shift: activation -> {- empty -}]
{- empty -} %shift { ([],Nothing) }
| explicit_activation { (fst $1,Just (snd $1)) }
explicit_activation :: { ([AddAnn],Activation) } -- In brackets
......
......@@ -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)
}
......
......@@ -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
......@@ -76,12 +76,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
......@@ -138,9 +139,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
......@@ -184,7 +187,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
; mapM_ dependentArgErr bad_args
; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
; 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
......@@ -342,6 +345,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 }
......@@ -349,6 +353,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
......@@ -440,7 +445,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
; traceTc "tcCheckPatSynDecl }" $ ppr 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)
......@@ -659,6 +664,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
......@@ -666,7 +672,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name
-> [Name] -- ^ 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)
......@@ -697,7 +703,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)
......@@ -707,7 +713,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
-- TODO: Make this have the proper information
; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
......@@ -744,13 +750,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
......@@ -813,17 +820,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
......@@ -849,10 +858,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
......@@ -869,8 +879,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)
......@@ -1141,12 +1154,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.
-}
......
......@@ -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)
......
......@@ -520,4 +520,38 @@ below:
*Main> g (False:undefined)
False
Pragmas for pattern synonyms
----------------------------
The :ref:`inlinable-pragma`, :ref:`inline-pragma` and :ref:`noinline-pragma` are supported for pattern
synonyms. For example: ::
patternInlinablePattern x = [x]
{-# INLINABLE InlinablePattern #-}
pattern InlinedPattern x = [x]
{-# INLINE InlinedPattern #-}
pattern NonInlinedPattern x = [x]
{-# NOINLINE NonInlinedPattern #-}
As with other ``INLINABLE``, ``INLINE`` and ``NOINLINE`` pragmas, it's possible to specify
to which phase the pragma applies: ::
pattern Q x = [x]
{-# NOINLINE[1] Q #-}
The pragmas are applied both when the pattern is used as a matcher, and as a
data constructor. For explicitly bidirectional pattern synonyms, the pragma
must be at top level, not nested in the where clause. For example, this won't compile: ::
pattern HeadC x <- x:xs where
HeadC x = [x]
{-# INLINE HeadC #-}
but this will: ::
pattern HeadC x <- x:xs where
HeadC x = [x]
{-# INLINE HeadC #-}
When no pragma is provided for a pattern, the inlining decision is made by
GHC's own inlining heuristics.
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_ExplicitBidiBuilder where
-- Explicit bidirectional pattern
pattern ExplicitPattern x <- x:xs where
ExplicitPattern x = [x]
{-# INLINE ExplicitPattern #-}
testExplicitBuilder x = ExplicitPattern (x+1)
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_ExplicitBidiMatcher where
-- Explicit bidirectional pattern
pattern ExplicitPattern x <- x:xs where
ExplicitPattern x = [x]
{-# INLINE ExplicitPattern #-}
testMatcherofExplicitBuilder (ExplicitPattern x) = 1
testMatcherofExplicitBuilder _ = 2
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_InlinableBuilder where
-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
pattern InlinablePattern a = [[[[a]]]]
{-# INLINABLE InlinablePattern #-}
testInBuilder x = InlinablePattern (x+1)
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_InlinableMatcher where
-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
pattern InlinablePattern a = [[[[a]]]]
{-# INLINEABLE InlinablePattern #-}
testInMatcher (InlinablePattern x) = 1
testInMatcher _ = 2
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_InlineBuilder where
-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
pattern InlinePattern a = [[[[a]]]]
{-# INLINE InlinePattern #-}
testInBuilder x = InlinePattern (x+1)
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_InlineMatcher where
-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
pattern InlinePattern a = [[[[a]]]]
{-# INLINE InlinePattern #-}
testInMatcher (InlinePattern x) = 1
testInMatcher _ = 2
{-# LANGUAGE PatternSynonyms #-}
module InlinePatSyn_NoInlineBuilder where
-- Pattern with "NOINLINE" pragma, neither builder nor matcher should be inlined
pattern NonInlinablePattern a = Left a
{-# NOINLINE NonInlinablePattern #-}
testNonBuilder x = NonInlinablePattern (x+1)
{-# LANGUAGE PatternSynonyms #-}
module T12178 where
-- Pattern with "NOINLINE" pragma, neither builder nor matcher should be inlined
pattern NonInlinablePattern a = Left a
{-# NOINLINE NonInlinablePattern #-}
testNonMatcher (NonInlinablePattern x) = 1
testNonMatcher _ = 2
......@@ -80,3 +80,40 @@ T17566:
$(RM) -f T17566a.o T17566a.hi T17566.o T17566.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c T17566a.hs
'$(TEST_HC)' $(TEST_HC_OPTS) -c T17566.hs
# In the InlinePatSyn tests, we're interested in whether the pattern synonym (whose name always contains the string 'Pattern').
# is inlined or not. To determine this, we use sed to isolate lines between the start and end of the test definition. That is,
# from a line starting with 'test', to a blank line. We then use grep to determine if 'Pattern' occurs anywhere in the definition
# in the core. If it was inlined, it naturally won't occur, so grep -v will succeed, if it wasn't then plain grep will succeed.
InlinePatSyn_InlinableBuilder:
$(RM) -f InlinePatSyn_InlinableBuilder.o InlinePatSyn_InlinableBuilder.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlinableBuilder.hs -O -dsuppress-all -ddump-hi | grep -q 'Inline:'
InlinePatSyn_InlinableMatcher:
$(RM) -f InlinePatSyn_InlinableMatcher.o InlinePatSyn_InlinableMatcher.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlinableMatcher.hs -O -dsuppress-all -ddump-hi | grep -q 'Inline:'
InlinePatSyn_InlineBuilder:
$(RM) -f InlinePatSyn_InlineBuilder.o InlinePatSyn_InlineBuilder.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlineBuilder.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
InlinePatSyn_InlineMatcher:
$(RM) -f InlinePatSyn_InlineMatcher.o InlinePatSyn_InlineMatcher.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlineMatcher.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
InlinePatSyn_NoInlineBuilder:
$(RM) -f InlinePatSyn_NoInlineBuilder.o InlinePatSyn_NoInlineBuilder.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_NoInlineBuilder.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -q 'Pattern'
InlinePatSyn_NoInlineMatcher:
$(RM) -f InlinePatSyn_NoInlineMatcher.o InlinePatSyn_NoInlineMatcher.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_NoInlineMatcher.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -q 'Pattern'
InlinePatSyn_ExplicitBidiBuilder:
$(RM) -f InlinePatSyn_ExplicitBidiBuilder.o InlinePatSyn_ExplicitBidiBuilder.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_ExplicitBidiBuilder.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
InlinePatSyn_ExplicitBidiMatcher:
$(RM) -f InlinePatSyn_ExplicitBidiMatcher.o InlinePatSyn_ExplicitBidiMatcher.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_ExplicitBidiMatcher.hs -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
......@@ -731,3 +731,12 @@ test('T18939_Compile', normal, compile, [''])
test('T15942', normal, compile, [''])
test('ClassDefaultInHsBoot', [extra_files(['ClassDefaultInHsBootA1.hs','ClassDefaultInHsBootA2.hs','ClassDefaultInHsBootA2.hs-boot','ClassDefaultInHsBootA3.hs'])], multimod_compile, ['ClassDefaultInHsBoot', '-v0'])
test('T17186', normal, compile, [''])
test('InlinePatSyn_InlinableBuilder', [], makefile_test, [])
test('InlinePatSyn_InlinableMatcher', [], makefile_test, [])
test('InlinePatSyn_InlineBuilder', [], makefile_test, [])
test('InlinePatSyn_InlineMatcher', [], makefile_test, [])
test('InlinePatSyn_NoInlineBuilder', [], makefile_test, [])
test('InlinePatSyn_NoInlineMatcher', [], makefile_test, [])
test('InlinePatSyn_ExplicitBidiBuilder', [], makefile_test, [])
test('InlinePatSyn_ExplicitBidiMatcher', [], makefile_test, [])
{-# LANGUAGE PatternSynonyms #-}
module T12178a where
-- Trying to inline a data constructor fails
data L a = C a (L a) | T
{-# INLINE C #-}
T12178a.hs:7:12: error:
The INLINE pragma for ‘C’ lacks an accompanying binding
(The INLINE pragma must be given where ‘C’ is declared)
......@@ -590,3 +590,5 @@ test('T18640b', normal, compile_fail, [''])
test('T18640c', normal, compile_fail, [''])
test('T10709', normal, compile_fail, [''])
test('T10709b', normal, compile_fail, [''])
test('T12178a', normal, compile_fail, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment