summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
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