diff options
author | Simon Peyton Jones <simon.peytonjones@gmail.com> | 2022-05-09 22:56:22 +0100 |
---|---|---|
committer | Zubin Duggal <zubin.duggal@gmail.com> | 2022-05-19 13:46:13 +0530 |
commit | 34e224ea564fcc53d46a52a2082b7f5e633f56a3 (patch) | |
tree | 3c5da025fe73959f5ece72a23b79598a096cf622 | |
parent | cce2270e9e158125f54ce3d7ac29c774b2fd0b57 (diff) | |
download | haskell-34e224ea564fcc53d46a52a2082b7f5e633f56a3.tar.gz |
Add arity to the INLINE pragmas for pattern synonyms
The lack of INLNE arity was exposed by #21531. The fix is
simple enough, if a bit clumsy.
(cherry picked from commit 65d31d05565073a37f9df73c9ea6f6f87627f26e)
-rw-r--r-- | compiler/GHC/Tc/Gen/Sig.hs | 56 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 55 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_compile/T21531.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_compile/T21531.stderr | 123 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_compile/all.T | 1 |
5 files changed, 214 insertions, 34 deletions
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 1d81b3636b..e1c1381e21 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -20,7 +20,8 @@ module GHC.Tc.Gen.Sig( tcInstSig, TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, - mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags + mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, + addInlinePrags, addInlinePragArity ) where #include "HsVersions.h" @@ -47,7 +48,6 @@ import GHC.Core.Multiplicity import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Driver.Ppr import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, setInlinePragma , mkLocalId, realIdUnfolding ) @@ -545,29 +545,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 - | Inline <- inl_inline 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 -> WARN( True, text "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) @@ -604,6 +607,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 b19da00ae3..111853d4d6 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -26,7 +26,8 @@ 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 ( 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 @@ -771,7 +772,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 @@ -791,7 +792,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 @@ -827,7 +828,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (L loc name)) [] + match = mkMatch (mkPrefixFunRhs (L loc ps_name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (EmptyLocalBinds noExtField) @@ -836,16 +837,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) } @@ -891,6 +897,7 @@ mkPatSynBuilder dir (L _ name) mkPhiTy theta $ mkVisFunTysMany arg_tys $ pat_ty + ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } tcPatSynBuilderBind :: TcPragEnv @@ -925,11 +932,17 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $ 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 @@ -943,8 +956,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 } } } @@ -1186,18 +1198,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 #-} @@ -1205,6 +1218,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 defb2ac52b..b423d9835b 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -80,3 +80,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']) |