summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlina Banerjee <alina@glitchgirl.us>2021-08-05 08:08:31 +0000
committerAlina Banerjee <alina@glitchgirl.us>2021-08-10 12:23:25 +0000
commita81c0c5b2f1c44900053043ffa7c0a30875b6843 (patch)
tree0ae7535c612ad0857efc36c30a6fc49e57ea84cc
parent5d651c78fed7e55b3b3cd21a04499d1a2f75204d (diff)
downloadhaskell-wip/fix-18138.tar.gz
Modify InlineSpec data constructor (helps fix #18138)wip/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
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs2
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs4
-rw-r--r--compiler/GHC/Core/Unfold.hs8
-rw-r--r--compiler/GHC/Hs/Binds.hs10
-rw-r--r--compiler/GHC/HsToCore/Binds.hs11
-rw-r--r--compiler/GHC/HsToCore/Quote.hs8
-rw-r--r--compiler/GHC/Parser.y6
-rw-r--r--compiler/GHC/Parser/Lexer.x12
-rw-r--r--compiler/GHC/Parser/PostProcess.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs2
-rw-r--r--compiler/GHC/ThToHs.hs26
-rw-r--r--compiler/GHC/Types/Basic.hs105
-rw-r--r--compiler/GHC/Types/Id/Make.hs3
-rw-r--r--compiler/Language/Haskell/Syntax/Binds.hs23
-rw-r--r--testsuite/tests/rename/should_fail/Misplaced.stderr4
-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.stderr4
-rw-r--r--testsuite/tests/rename/should_fail/all.T2
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 946b9a87f3..e4abe4043d 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 de2602e6c5..c0949c493b 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, [''])
View Lorry Controller Status