diff options
author | Alina Banerjee <alina@glitchgirl.us> | 2021-08-05 08:08:31 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-08-11 18:15:05 -0400 |
commit | 100ffe75f509a73f1b26e768237888646f522b6c (patch) | |
tree | 56702bfdf582572a41b1bfbe9b066039023c0f95 | |
parent | f5fdace5613914724eb00bcf7547c82f3ad12686 (diff) | |
download | haskell-100ffe75f509a73f1b26e768237888646f522b6c.tar.gz |
Modify InlineSpec data constructor (helps fix #18138)
The inl_inline field of the InlinePragma record is modified to store pragma
source text by adding a data constructor of type SourceText. This can help in
tracking the actual text of pragma names.
Add/modify functions, modify type instance for InlineSpec type
Modify parser, lexer to handle InlineSpec constructors containing SourceText
Modify functions with InlineSpec type
Extract pragma source from InlineSpec for SpecSig, InlineSig types
Modify cvtInline function to add SourceText to InlineSpec type
Extract name for InlineSig, SpecSig from pragma, SpectInstSig from source (fixes #18138)
Extract pragma name for SpecPrag pragma, SpecSig signature
Add Haddock annotation for inlinePragmaName function
Add Haddock annotations for using helper functions in hsSigDoc
Remove redundant ppr in pragma name for SpecSig, InlineSig; update comment
Rename test to T18138 for misplaced SPECIALIZE pragma testcase
-rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Hs/Binds.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Binds.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Parser.y | 6 | ||||
-rw-r--r-- | compiler/GHC/Parser/Lexer.x | 12 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Sig.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 105 | ||||
-rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 3 | ||||
-rw-r--r-- | compiler/Language/Haskell/Syntax/Binds.hs | 23 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/Misplaced.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/T18138.hs (renamed from testsuite/tests/rename/should_fail/Misplaced.hs) | 0 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/T18138.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/all.T | 2 |
18 files changed, 147 insertions, 87 deletions
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 05d2e868aa..7071932e2a 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1578,7 +1578,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs = (neverInlinePragma, noUnfolding) -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" - | InlinePragma { inl_inline = Inlinable } <- inl_prag + | isInlinablePragma inl_prag = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding) | otherwise diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index ffb8f5c889..7cb9d6ad2f 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -745,8 +745,8 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div cpr work_rhs = work_fn (mkLams fn_args fn_body) work_act = case fn_inline_spec of -- See Note [Worker activation] - NoInline -> inl_act fn_inl_prag - _ -> inl_act wrap_prag + NoInline _ -> inl_act fn_inl_prag + _ -> inl_act wrap_prag work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = fn_inline_spec diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 4e895b8b09..f8dadf8c16 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -50,7 +50,7 @@ import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info -import GHC.Types.Basic ( Arity, InlineSpec(..), inlinePragmaSpec ) +import GHC.Types.Basic ( Arity, isNoInlinePragma ) import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -970,7 +970,7 @@ certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding certainlyWillInline opts fn_info = case fn_unf of CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src } - | noinline -> Nothing -- See Note [Worker/wrapper for NOINLINE functions] + | noinline -> Nothing -- See Note [Worker/wrapper for NOINLINE functions] | otherwise -> case guidance of UnfNever -> Nothing @@ -991,8 +991,8 @@ certainlyWillInline opts fn_info _other_unf -> Nothing where - noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline - fn_unf = unfoldingInfo fn_info -- NB: loop-breakers never inline + noinline = isNoInlinePragma (inlinePragInfo fn_info) + fn_unf = unfoldingInfo fn_info -- NB: loop-breakers never inline -- The UnfIfGoodArgs case seems important. If we w/w small functions -- binary sizes go up by 10%! (This is with SplitObjs.) diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index e909303c25..86424b71b6 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -609,14 +609,14 @@ ppr_sig (ClassOpSig _ is_deflt vars ty) ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig _ fix_sig) = ppr fix_sig ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) - = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) + = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var) (interpp'SP ty) inl) where pragmaSrc = case spec of - NoUserInlinePrag -> "{-# SPECIALISE" - _ -> "{-# SPECIALISE_INLINE" + NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl) + _ -> "{-# " ++ extractSpecPragName (inl_src inl) ++ "_INLINE" ppr_sig (InlineSig _ var inl) - = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl + = pragSrcBrackets (inlinePragmaSource inl) "{-# INLINE" (pprInline inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig _ src ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) @@ -674,7 +674,7 @@ pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where ppr (SpecPrag var _ inl) - = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl + = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl pprMinimalSig :: (OutputableBndr name) => LBooleanFormula (GenLocated l name) -> SDoc diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 01a8d1d9a5..602de4070a 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -397,10 +397,9 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs | otherwise = case inlinePragmaSpec inline_prag of NoUserInlinePrag -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair - + NoInline {} -> (gbl_id, rhs) + Inlinable {} -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline {} -> inline_pair where simpl_opts = initSimpleOpts dflags inline_prag = idInlinePragma gbl_id @@ -768,8 +767,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- no_act_spec is True if the user didn't write an explicit -- phase specification in the SPECIALISE pragma no_act_spec = case inlinePragmaSpec spec_inl of - NoInline -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act + NoInline _ -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit | otherwise = spec_prag_act -- Specified by user diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index ec7cb058ca..ea185b076f 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1118,10 +1118,10 @@ rep_specialiseInst ty loc ; return [(loc, pragma)] } repInline :: InlineSpec -> MetaM (Core TH.Inline) -repInline NoInline = dataCon noInlineDataConName -repInline Inline = dataCon inlineDataConName -repInline Inlinable = dataCon inlinableDataConName -repInline NoUserInlinePrag = notHandled ThNoUserInline +repInline (NoInline _ ) = dataCon noInlineDataConName +repInline (Inline _ ) = dataCon inlineDataConName +repInline (Inlinable _ ) = dataCon inlinableDataConName +repInline NoUserInlinePrag = notHandled ThNoUserInline repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 15088081e1..1c0c65bb96 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -3888,8 +3888,8 @@ getPRIMWORD (L _ (ITprimword _ x)) = x getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l @@ -3902,7 +3902,7 @@ getPRIMINTEGERs (L _ (ITprimint src _)) = src getPRIMWORDs (L _ (ITprimword src _)) = src -- See Note [Pragma source text] in "GHC.Types.Basic" for the following -getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src +getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl getSPEC_PRAGs (L _ (ITspec_prag src)) = src getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src getSOURCE_PRAGs (L _ (ITsource_prag src)) = src diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index b63ce55669..10568814d7 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -3418,14 +3418,14 @@ ignoredPrags = Map.fromList (map ignored pragmas) oneWordPrags = Map.fromList [ ("rules", rulePrag), ("inline", - strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), + strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))), ("inlinable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), ("inlineable", - strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), -- Spelling variant ("notinline", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), + strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))), ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), ("source", strtoken (\s -> ITsource_prag (SourceText s))), ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), @@ -3446,9 +3446,9 @@ oneWordPrags = Map.fromList [ twoWordPrags = Map.fromList [ ("inline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), + strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))), ("notinline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), + strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))), ("specialize inline", strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), ("specialize notinline", diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 6b58b70558..4eab0c1486 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2514,8 +2514,8 @@ mkInlinePragma src (inl, match_info) mb_act Just act -> act Nothing -> -- No phase specified case inl of - NoInline -> NeverActive - _other -> AlwaysActive + NoInline _ -> NeverActive + _other -> AlwaysActive ----------------------------------------------------------------------------- -- utilities for foreign declarations diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index f318bfd140..67715e9b5b 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -581,7 +581,7 @@ mkPragEnv sigs binds get_sig _ = Nothing add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function - | Inline <- inl_inline inl_prag + | isInlinePragma inl_prag -- add arity only for real INLINE pragmas, not INLINABLE = case lookupNameEnv ar_env n of Just ar -> inl_prag { inl_sat = Just ar } diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 0f9bb35cd6..96a27a528c 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -778,11 +778,13 @@ cvtPragmaD (InlineP nm inline rm phases) ; let src TH.NoInline = "{-# NOINLINE" src TH.Inline = "{-# INLINE" src TH.Inlinable = "{-# INLINABLE" - ; let ip = InlinePragma { inl_src = SourceText $ src inline - , inl_inline = cvtInline inline + ; let ip = InlinePragma { inl_src = toSrcTxt inline + , inl_inline = cvtInline inline (toSrcTxt inline) , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } + where + toSrcTxt a = SourceText $ src a ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } cvtPragmaD (SpecialiseP nm ty inline phases) @@ -791,12 +793,14 @@ cvtPragmaD (SpecialiseP nm ty inline phases) ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" src TH.Inline = "{-# SPECIALISE INLINE" src TH.Inlinable = "{-# SPECIALISE INLINE" - ; let (inline', dflt,srcText) = case inline of - Just inline1 -> (cvtInline inline1, dfltActivation inline1, - src inline1) + ; let (inline', dflt, srcText) = case inline of + Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1, + toSrcTxt inline1) Nothing -> (NoUserInlinePrag, AlwaysActive, - "{-# SPECIALISE") - ; let ip = InlinePragma { inl_src = SourceText srcText + SourceText "{-# SPECIALISE") + where + toSrcTxt a = SourceText $ src a + ; let ip = InlinePragma { inl_src = srcText , inl_inline = inline' , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt @@ -857,10 +861,10 @@ dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive dfltActivation _ = AlwaysActive -cvtInline :: TH.Inline -> Hs.InlineSpec -cvtInline TH.NoInline = Hs.NoInline -cvtInline TH.Inline = Hs.Inline -cvtInline TH.Inlinable = Hs.Inlinable +cvtInline :: TH.Inline -> SourceText -> Hs.InlineSpec +cvtInline TH.NoInline srcText = Hs.NoInline srcText +cvtInline TH.Inline srcText = Hs.Inline srcText +cvtInline TH.Inlinable srcText = Hs.Inlinable srcText cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo cvtRuleMatch TH.ConLike = Hs.ConLike diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index eccffc8525..b28ef41cae 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -84,7 +84,10 @@ module GHC.Types.Basic ( InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, isDefaultInlinePragma, - isInlinePragma, isInlinablePragma, isAnyInlinePragma, + isInlinePragma, isInlinablePragma, isNoInlinePragma, + isAnyInlinePragma, alwaysInlineConLikePragma, + inlinePragmaSource, + inlinePragmaName, inlineSpecSource, inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, @@ -1330,9 +1333,11 @@ data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] -- | Inline Specification data InlineSpec -- What the user's INLINE pragma looked like - = Inline -- User wrote INLINE - | Inlinable -- User wrote INLINABLE - | NoInline -- User wrote NOINLINE + = Inline SourceText -- User wrote INLINE + | Inlinable SourceText -- User wrote INLINABLE + | NoInline SourceText -- User wrote NOINLINE + -- Each of the above keywords is accompanied with + -- a string of type SourceText written by the user | NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE -- e.g. in `defaultInlinePragma` or when created by CSE deriving( Eq, Data, Show ) @@ -1429,12 +1434,29 @@ defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = NoUserInlinePrag , inl_sat = Nothing } -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline (inlinePragmaSource defaultInlinePragma) } neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } +alwaysInlineConLikePragma :: InlinePragma +alwaysInlineConLikePragma = alwaysInlinePragma { inl_rule = ConLike } + inlinePragmaSpec :: InlinePragma -> InlineSpec inlinePragmaSpec = inl_inline +inlinePragmaSource :: InlinePragma -> SourceText +inlinePragmaSource prag = case inl_inline prag of + Inline x -> x + Inlinable y -> y + NoInline z -> z + NoUserInlinePrag -> NoSourceText + +inlineSpecSource :: InlineSpec -> SourceText +inlineSpecSource spec = case spec of + Inline x -> x + Inlinable y -> y + NoInline z -> z + NoUserInlinePrag -> NoSourceText + -- A DFun has an always-active inline activation so that -- exprIsConApp_maybe can "see" its unfolding -- (However, its actual Unfolding is a DFunUnfolding, which is @@ -1450,20 +1472,25 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = case inl_inline prag of - Inline -> True - _ -> False + Inline _ -> True + _ -> False isInlinablePragma :: InlinePragma -> Bool isInlinablePragma prag = case inl_inline prag of - Inlinable -> True - _ -> False + Inlinable _ -> True + _ -> False + +isNoInlinePragma :: InlinePragma -> Bool +isNoInlinePragma prag = case inl_inline prag of + NoInline _ -> True + _ -> False isAnyInlinePragma :: InlinePragma -> Bool -- INLINE or INLINABLE isAnyInlinePragma prag = case inl_inline prag of - Inline -> True - Inlinable -> True - _ -> False + Inline _ -> True + Inlinable _ -> True + _ -> False inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat @@ -1515,7 +1542,6 @@ instance Binary Activation where ab <- get bh return (ActiveAfter src ab) - instance Outputable RuleMatchInfo where ppr ConLike = text "CONLIKE" ppr FunLike = text "FUNLIKE" @@ -1529,24 +1555,32 @@ instance Binary RuleMatchInfo where else return FunLike instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr NoUserInlinePrag = empty + ppr (Inline src) = text "INLINE" <+> pprWithSourceText src empty + ppr (NoInline src) = text "NOINLINE" <+> pprWithSourceText src empty + ppr (Inlinable src) = text "INLINABLE" <+> pprWithSourceText src empty + ppr NoUserInlinePrag = empty instance Binary InlineSpec where put_ bh NoUserInlinePrag = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 + put_ bh (Inline s) = do putByte bh 1 + put_ bh s + put_ bh (Inlinable s) = do putByte bh 2 + put_ bh s + put_ bh (NoInline s) = do putByte bh 3 + put_ bh s get bh = do h <- getByte bh case h of 0 -> return NoUserInlinePrag - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - + 1 -> do + s <- get bh + return (Inline s) + 2 -> do + s <- get bh + return (Inlinable s) + _ -> do + s <- get bh + return (NoInline s) instance Outputable InlinePragma where ppr = pprInline @@ -1567,6 +1601,14 @@ instance Binary InlinePragma where d <- get bh return (InlinePragma s a b c d) +-- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This +-- differs from the Outputable instance for the InlineSpec type where the pragma +-- name string as well as the accompanying SourceText (if any) is printed. +inlinePragmaName :: InlineSpec -> SDoc +inlinePragmaName (Inline _) = text "INLINE" +inlinePragmaName (Inlinable _) = text "INLINABLE" +inlinePragmaName (NoInline _) = text "NOINLINE" +inlinePragmaName NoUserInlinePrag = empty pprInline :: InlinePragma -> SDoc pprInline = pprInline' True @@ -1577,15 +1619,18 @@ pprInlineDebug = pprInline' False pprInline' :: Bool -- True <=> do not display the inl_inline field -> InlinePragma -> SDoc -pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation - , inl_rule = info, inl_sat = mb_arity }) +pprInline' emptyInline (InlinePragma + { inl_inline = inline, + inl_act = activation, + inl_rule = info, + inl_sat = mb_arity }) = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info where - pp_inl x = if emptyInline then empty else ppr x + pp_inl x = if emptyInline then empty else inlinePragmaName x - pp_act Inline AlwaysActive = empty - pp_act NoInline NeverActive = empty - pp_act _ act = ppr act + pp_act Inline {} AlwaysActive = empty + pp_act NoInline {} NeverActive = empty + pp_act _ act = ppr act pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) | otherwise = empty diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index cd91149007..88a7a211cd 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -841,8 +841,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con dataConWrapperInlinePragma :: InlinePragma -- See Note [DataCon wrappers are conlike] -dataConWrapperInlinePragma = alwaysInlinePragma { inl_rule = ConLike - , inl_inline = Inline } +dataConWrapperInlinePragma = alwaysInlineConLikePragma {- Note [Activation for data constructor wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs index 60ca3fad1b..e3e611674c 100644 --- a/compiler/Language/Haskell/Syntax/Binds.hs +++ b/compiler/Language/Haskell/Syntax/Binds.hs @@ -46,6 +46,7 @@ import GHC.Data.Bag import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Utils.Outputable +import GHC.Utils.Panic (pprPanic) import Data.Data hiding ( Fixity ) import Data.Void @@ -872,17 +873,29 @@ hsSigDoc (ClassOpSig _ is_deflt _ _) | is_deflt = text "default type signature" | otherwise = text "class method signature" hsSigDoc (IdSig {}) = text "id signature" -hsSigDoc (SpecSig _ _ _ inl) - = ppr inl <+> text "pragma" -hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" -hsSigDoc (SpecInstSig _ src _) - = pprWithSourceText src empty <+> text "instance pragma" +hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" +hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" +-- Using the 'inlinePragmaName' function ensures that the pragma name for any +-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted +-- from the InlineSpec field of the pragma. +hsSigDoc (SpecInstSig _ src _) = text (extractSpecPragName src) <+> text "instance pragma" hsSigDoc (FixSig {}) = text "fixity declaration" hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" hsSigDoc (SCCFunSig {}) = text "SCC pragma" hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" hsSigDoc (XSig {}) = text "XSIG TTG extension" +-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src +-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE +-- instance pragma of the form: "SourceText {-# SPECIALIZE" +-- +-- Extraction ensures that all variants of the pragma name (with a 'Z' or an +-- 'S') are output exactly as used in the pragma. +extractSpecPragName :: SourceText -> String +extractSpecPragName srcTxt = case (words $ show srcTxt) of + (_:_:pragName:_) -> filter (/= '\"') pragName + _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) + {- ************************************************************************ * * diff --git a/testsuite/tests/rename/should_fail/Misplaced.stderr b/testsuite/tests/rename/should_fail/Misplaced.stderr deleted file mode 100644 index 85f2d9e4e4..0000000000 --- a/testsuite/tests/rename/should_fail/Misplaced.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -Misplaced.hs:4:1: error: - Misplaced {-# SPECIALISE instance pragma: - {-# SPECIALISE instance Eq (T Int) #-} diff --git a/testsuite/tests/rename/should_fail/Misplaced.hs b/testsuite/tests/rename/should_fail/T18138.hs index ef4aa7ff9a..ef4aa7ff9a 100644 --- a/testsuite/tests/rename/should_fail/Misplaced.hs +++ b/testsuite/tests/rename/should_fail/T18138.hs diff --git a/testsuite/tests/rename/should_fail/T18138.stderr b/testsuite/tests/rename/should_fail/T18138.stderr new file mode 100644 index 0000000000..dea2871a51 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T18138.stderr @@ -0,0 +1,4 @@ + +T18138.hs:4:1: error: + Misplaced SPECIALISE instance pragma: + {-# SPECIALISE instance Eq (T Int) #-} diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index c25a7c3d92..6c2f0134a0 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -79,7 +79,6 @@ test('T5385', [], multimod_compile_fail, ['T5385', '-v0']) test('T5513', normal, compile_fail, ['']) test('T5533', normal, compile_fail, ['']) test('T5589', normal, compile_fail, ['']) -test('Misplaced', normal, compile_fail, ['']) test('T5657', normal, compile_fail, ['']) test('T5745', [], multimod_compile_fail, ['T5745', '-v0']) test('T5892a', normal, compile_fail, ['-package containers']) @@ -179,3 +178,4 @@ test('T19843k', normal, compile_fail, ['']) test('T19843l', normal, compile_fail, ['']) test('T19843m', normal, compile_fail, ['']) test('T11167_ambig', normal, compile_fail, ['']) +test('T18138', normal, compile_fail, ['']) |