summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorZubin Duggal <zubin.duggal@gmail.com>2023-05-04 05:30:13 +0530
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-05-16 14:00:00 -0400
commit90e69d5d167b9d6cd63b04e42f8af375dc4b307f (patch)
tree8ce2679872dbc4c4a5cc60025fe9564d36fc7772
parent5e3f9bb57680a40f6a9531e41dc2617c5f028e5c (diff)
downloadhaskell-90e69d5d167b9d6cd63b04e42f8af375dc4b307f.tar.gz
compiler: Use compact representation for SourceText
SourceText is serialized along with INLINE pragmas into interface files. Many of these SourceTexts are identical, for example "{-# INLINE#". When deserialized, each such SourceText was previously expanded out into a [Char], which is highly wasteful of memory, and each such instance of the text would allocate an independent list with its contents as deserializing breaks any sharing that might have existed. Instead, we use a `FastString` to represent these, so that each instance unique text will be interned and stored in a memory efficient manner.
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Iteration.hs2
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs6
-rw-r--r--compiler/GHC/Hs/Binds.hs4
-rw-r--r--compiler/GHC/Hs/Decls.hs4
-rw-r--r--compiler/GHC/Hs/Dump.hs4
-rw-r--r--compiler/GHC/Hs/Expr.hs4
-rw-r--r--compiler/GHC/Hs/ImpExp.hs2
-rw-r--r--compiler/GHC/Parser/Lexer.x76
-rw-r--r--compiler/GHC/Parser/PostProcess.hs5
-rw-r--r--compiler/GHC/ThToHs.hs42
-rw-r--r--compiler/GHC/Types/Basic.hs2
-rw-r--r--compiler/GHC/Types/SourceText.hs28
-rw-r--r--compiler/GHC/Unit/Module/Warnings.hs4
-rw-r--r--testsuite/tests/ghc-api/annotations-literals/parsed.hs25
-rw-r--r--utils/check-exact/ExactPrint.hs26
15 files changed, 123 insertions, 111 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 1ecfa632e1..5a6644fd3e 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -668,7 +668,7 @@ tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings
mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
-- See Note [Cast worker/wrapper]
mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })
- = InlinePragma { inl_src = SourceText "{-# INLINE"
+ = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions]
, inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap
, inl_act = wrap_act -- See Note [Wrapper activation]
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 29f1e3973f..061f98f1bc 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -20,6 +20,8 @@ import GHC.Core.Type
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.SimpleOpt
+import GHC.Data.FastString
+
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -819,7 +821,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
NoInline _ -> inl_act fn_inl_prag
_ -> inl_act wrap_prag
- work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
+ work_prag = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_inline = fn_inline_spec
, inl_sat = Nothing
, inl_act = work_act
@@ -887,7 +889,7 @@ mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma
mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
, inl_act = fn_act
, inl_rule = rule_info }) rules
- = InlinePragma { inl_src = SourceText "{-# INLINE"
+ = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_sat = Nothing
, inl_inline = fn_inl
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index c7dd8fca0f..ca4b6b08e2 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -756,7 +756,7 @@ ppr_sig (InlineSig _ var inl)
= ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}"
where
ppr_pfx = case inlinePragmaSource inl of
- SourceText src -> text src
+ SourceText src -> ftext src
NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl)
ppr_sig (SpecInstSig (_, src) ty)
= pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)
@@ -828,7 +828,7 @@ pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
-- | Using SourceText in case the pragma was spelled differently or used mixed
-- case
pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
-pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}"
+pragSrcBrackets (SourceText src) _ doc = ftext src <+> doc <+> text "#-}"
pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}"
pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 201adc5467..07bcba6cc4 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -913,7 +913,7 @@ ppOverlapPragma mb =
Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}"
where
maybe_stext NoSourceText alt = text alt
- maybe_stext (SourceText src) _ = text src <+> text "#-}"
+ maybe_stext (SourceText src) _ = ftext src <+> text "#-}"
instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
@@ -1219,7 +1219,7 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
- = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ = ftext src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
where src = case ghcPass @p of
GhcPs | (_, SourceText src) <- ext -> src
GhcRn | SourceText src <- ext -> src
diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs
index 794607bd49..245a1cd43e 100644
--- a/compiler/GHC/Hs/Dump.hs
+++ b/compiler/GHC/Hs/Dump.hs
@@ -139,8 +139,8 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
sourceText :: SourceText -> SDoc
sourceText NoSourceText = parens $ text "NoSourceText"
sourceText (SourceText src) = case bs of
- NoBlankSrcSpan -> parens $ text "SourceText" <+> text src
- BlankSrcSpanFile -> parens $ text "SourceText" <+> text src
+ NoBlankSrcSpan -> parens $ text "SourceText" <+> ftext src
+ BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src
_ -> parens $ text "SourceText" <+> text "blanked"
epaAnchor :: EpaLocation -> SDoc
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index be7af5002a..385bbd62c7 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -131,7 +131,7 @@ data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
noExpr :: HsExpr (GhcPass p)
-noExpr = HsLit noComments (HsString (SourceText "noExpr") (fsLit "noExpr"))
+noExpr = HsLit noComments (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))
noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)
-- Before renaming, and sometimes after
@@ -519,7 +519,7 @@ ppr_expr (HsRecSel _ f) = pprPrefixOcc f
ppr_expr (HsIPVar _ v) = ppr v
ppr_expr (HsOverLabel _ s l) = char '#' <> case s of
NoSourceText -> ppr l
- SourceText src -> text src
+ SourceText src -> ftext src
ppr_expr (HsLit _ lit) = ppr lit
ppr_expr (HsOverLit _ lit) = ppr lit
ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e)
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 83f5cfbb88..06a6cc783e 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -171,7 +171,7 @@ instance (OutputableBndrId p
GhcTc -> dataConCantHappen ext
in case mSrcText of
NoSourceText -> text "{-# SOURCE #-}"
- SourceText src -> text src <+> text "#-}"
+ SourceText src -> ftext src <+> text "#-}"
ppr_imp _ NotBoot = empty
pp_spec Nothing = empty
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 48a1a367c2..61235f5942 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -42,6 +42,7 @@
{
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -1215,7 +1216,7 @@ skip_one_varid f span buf len _buf2
skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action
skip_one_varid_src f span buf len _buf2
- = return (L span $! f (SourceText $ lexemeToString (stepOn buf) (len-1))
+ = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1))
(lexemeToFastString (stepOn buf) (len-1)))
skip_two_varid :: (FastString -> Token) -> Action
@@ -1226,6 +1227,10 @@ strtoken :: (String -> Token) -> Action
strtoken f span buf len _buf2 =
return (L span $! (f $! lexemeToString buf len))
+fstrtoken :: (FastString -> Token) -> Action
+fstrtoken f span buf len _buf2 =
+ return (L span $! (f $! lexemeToFastString buf len))
+
begin :: Int -> Action
begin code _span _str _len _buf2 = do pushLexState code; lexToken
@@ -1620,7 +1625,7 @@ mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)
rulePrag :: Action
rulePrag span buf len _buf2 = do
setExts (.|. xbit InRulePragBit)
- let !src = lexemeToString buf len
+ let !src = lexemeToFastString buf len
return (L span (ITrules_prag (SourceText src)))
-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
@@ -1630,7 +1635,7 @@ linePrag span buf len buf2 = do
usePosPrags <- getBit UsePosPragsBit
if usePosPrags
then begin line_prag2 span buf len buf2
- else let !src = lexemeToString buf len
+ else let !src = lexemeToFastString buf len
in return (L span (ITline_prag (SourceText src)))
-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
@@ -1638,10 +1643,9 @@ linePrag span buf len buf2 = do
columnPrag :: Action
columnPrag span buf len buf2 = do
usePosPrags <- getBit UsePosPragsBit
- let !src = lexemeToString buf len
if usePosPrags
then begin column_prag span buf len buf2
- else let !src = lexemeToString buf len
+ else let !src = lexemeToFastString buf len
in return (L span (ITcolumn_prag (SourceText src)))
endPrag :: Action
@@ -1888,8 +1892,8 @@ tok_integral :: (SourceText -> Integer -> Token)
-> Action
tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do
numericUnderscores <- getBit NumericUnderscoresBit -- #14473
- let src = lexemeToString buf len
- when ((not numericUnderscores) && ('_' `elem` src)) $ do
+ let src = lexemeToFastString buf len
+ when ((not numericUnderscores) && ('_' `elem` unpackFS src)) $ do
pState <- getPState
let msg = PsErrNumUnderscores NumUnderscore_Integral
addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
@@ -1901,7 +1905,7 @@ tok_num :: (Integer -> Integer)
-> Int -> Int
-> (Integer, (Char->Int)) -> Action
tok_num = tok_integral $ \case
- st@(SourceText ('-':_)) -> itint st (const True)
+ st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True)
st@(SourceText _) -> itint st (const False)
st@NoSourceText -> itint st (< 0)
where
@@ -2165,7 +2169,7 @@ lex_string_tok span buf _len _buf2 = do
tok = case lexed of
LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s)
LexedRegularString s -> ITstring (SourceText src) (mkFastString s)
- src = lexemeToString buf (cur bufEnd - cur buf)
+ src = lexemeToFastString buf (cur bufEnd - cur buf)
return $ L (mkPsSpan (psSpanStart span) end) tok
@@ -2176,7 +2180,7 @@ lex_quoted_label span buf _len _buf2 = do
(AI end bufEnd) <- getInput
let
token = ITlabelvarid (SourceText src) (mkFastString s)
- src = lexemeToString (stepOn buf) (cur bufEnd - cur buf - 1)
+ src = lexemeToFastString (stepOn buf) (cur bufEnd - cur buf - 1)
start = psSpanStart span
return $ L (mkPsSpan start end) token
@@ -2301,13 +2305,13 @@ finish_char_tok buf loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- getBit MagicHashBit
i@(AI end bufEnd) <- getInput
- let src = lexemeToString buf (cur bufEnd - cur buf)
+ let src = lexemeToFastString buf (cur bufEnd - cur buf)
if magicHash then do
case alexGetChar' i of
Just ('#',i@(AI end bufEnd')) -> do
setInput i
-- Include the trailing # in SourceText
- let src' = lexemeToString buf (cur bufEnd' - cur buf)
+ let src' = lexemeToFastString buf (cur bufEnd' - cur buf)
return (L (mkPsSpan loc end)
(ITprimchar (SourceText src') ch))
_other ->
@@ -3691,42 +3695,42 @@ ignoredPrags = Map.fromList (map ignored pragmas)
oneWordPrags = Map.fromList [
("rules", rulePrag),
("inline",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),
("inlinable",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
("inlineable",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
-- Spelling variant
("notinline",
- strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),
- ("opaque", strtoken (\s -> ITopaque_prag (SourceText s))),
- ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
- ("source", strtoken (\s -> ITsource_prag (SourceText s))),
- ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
- ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
- ("scc", strtoken (\s -> ITscc_prag (SourceText s))),
- ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
- ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
- ("ann", strtoken (\s -> ITann_prag (SourceText s))),
- ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
- ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
- ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
- ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
- ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
- ("ctype", strtoken (\s -> ITctype (SourceText s))),
- ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),
+ ("opaque", fstrtoken (\s -> ITopaque_prag (SourceText s))),
+ ("specialize", fstrtoken (\s -> ITspec_prag (SourceText s))),
+ ("source", fstrtoken (\s -> ITsource_prag (SourceText s))),
+ ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))),
+ ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))),
+ ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))),
+ ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))),
+ ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))),
+ ("ann", fstrtoken (\s -> ITann_prag (SourceText s))),
+ ("minimal", fstrtoken (\s -> ITminimal_prag (SourceText s))),
+ ("overlaps", fstrtoken (\s -> IToverlaps_prag (SourceText s))),
+ ("overlappable", fstrtoken (\s -> IToverlappable_prag (SourceText s))),
+ ("overlapping", fstrtoken (\s -> IToverlapping_prag (SourceText s))),
+ ("incoherent", fstrtoken (\s -> ITincoherent_prag (SourceText s))),
+ ("ctype", fstrtoken (\s -> ITctype (SourceText s))),
+ ("complete", fstrtoken (\s -> ITcomplete_prag (SourceText s))),
("column", columnPrag)
]
twoWordPrags = Map.fromList [
("inline conlike",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),
("notinline conlike",
- strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),
("specialize inline",
- strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
+ fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
("specialize notinline",
- strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
+ fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
]
dispatch_pragmas :: Map String Action -> Action
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 0b7053dcbb..52251b211c 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2717,7 +2717,8 @@ parseCImport cconv safety nm str sourceText =
((mk Nothing <$> cimp nm) +++
(do h <- munch1 hdr_char
skipSpaces
- mk (Just (Header (SourceText h) (mkFastString h)))
+ let src = mkFastString h
+ mk (Just (Header (SourceText src) src))
<$> cimp nm))
]
skipSpaces
@@ -3116,7 +3117,7 @@ mkLHsOpTy prom x op y =
in L loc (mkHsOpTy prom x op y)
mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
-mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr
+mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr
-- See #18888 for the use of (SourceText "1") above
= HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)
where
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 39da7e0c51..a28b4767b5 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -331,10 +331,10 @@ cvtDec (InstanceD o ctxt ty decs)
where
overlap pragma =
case pragma of
- TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS")
- TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE")
- TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING")
- TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT")
+ TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "OVERLAPS")
+ TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "OVERLAPPABLE")
+ TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "OVERLAPPING")
+ TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "INCOHERENT")
@@ -803,8 +803,8 @@ cvtForD (ImportF callconv safety from nm ty) =
-- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
| callconv == TH.Prim || callconv == TH.JavaScript
-> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing
- (CFunction (StaticTarget (SourceText from)
- (mkFastString from) Nothing
+ (CFunction (StaticTarget (SourceText fromtxt)
+ fromtxt Nothing
True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
@@ -813,6 +813,7 @@ cvtForD (ImportF callconv safety from nm ty) =
| otherwise
-> failWith $ InvalidCCallImpent from }
where
+ fromtxt = mkFastString from
mk_imp impspec
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
@@ -830,8 +831,9 @@ cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
; l <- getL
- ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as)
- (mkFastString as)
+ ; let astxt = mkFastString as
+ ; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt)
+ astxt
(cvt_conv callconv)))
; return $ ForeignExport { fd_e_ext = noAnn
, fd_name = nm'
@@ -856,9 +858,9 @@ cvtPragmaD (InlineP nm inline rm phases)
-- (e.g., `INLINE`d pattern synonyms, cf. #23203)
nm' <- vcNameN nm
; let dflt = dfltActivation inline
- ; let src TH.NoInline = "{-# NOINLINE"
- src TH.Inline = "{-# INLINE"
- src TH.Inlinable = "{-# INLINABLE"
+ ; let src TH.NoInline = fsLit "{-# NOINLINE"
+ src TH.Inline = fsLit "{-# INLINE"
+ src TH.Inlinable = fsLit "{-# INLINABLE"
; let ip = InlinePragma { inl_src = toSrcTxt inline
, inl_inline = cvtInline inline (toSrcTxt inline)
, inl_rule = cvtRuleMatch rm
@@ -876,20 +878,20 @@ cvtPragmaD (OpaqueP nm)
, inl_act = NeverActive
, inl_sat = Nothing }
where
- srcTxt = SourceText "{-# OPAQUE"
+ srcTxt = SourceText $ fsLit "{-# OPAQUE"
; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; let src TH.NoInline = "{-# SPECIALISE NOINLINE"
- src TH.Inline = "{-# SPECIALISE INLINE"
- src TH.Inlinable = "{-# SPECIALISE INLINE"
+ ; let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE"
+ src TH.Inline = fsLit "{-# SPECIALISE INLINE"
+ src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"
; let (inline', dflt, srcText) = case inline of
Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
toSrcTxt inline1)
Nothing -> (NoUserInlinePrag, AlwaysActive,
- SourceText "{-# SPECIALISE")
+ SourceText $ fsLit "{-# SPECIALISE")
where
toSrcTxt a = SourceText $ src a
; let ip = InlinePragma { inl_src = srcText
@@ -902,7 +904,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtSigType ty
; returnJustLA $ Hs.SigD noExtField $
- SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' }
+ SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' }
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
@@ -921,7 +923,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
- $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES")
+ $ HsRules { rds_ext = (noAnn, SourceText $ fsLit "{-# RULES")
, rds_rules = [rule] }
}
@@ -937,7 +939,7 @@ cvtPragmaD (AnnP target exp)
n' <- vcName n
wrapParLA ValueAnnProvenance n'
; returnJustLA $ Hs.AnnD noExtField
- $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp'
+ $ HsAnnotation (noAnn, (SourceText $ fsLit "{-# ANN")) target' exp'
}
-- NB: This is the only place in GHC.ThToHs that makes use of the `setL`
@@ -1405,7 +1407,7 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
-- "GHC.ThToHs", hence panic
quotedSourceText :: String -> SourceText
-quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
+quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\""
cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
cvtPats pats = mapM cvtPat pats
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 1f73c82028..7c9db88e26 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -1560,7 +1560,7 @@ noUserInlineSpec _ = False
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
:: InlinePragma
-defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
+defaultInlinePragma = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_act = AlwaysActive
, inl_rule = FunLike
, inl_inline = NoUserInlinePrag
diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs
index 72c77dec95..5995308505 100644
--- a/compiler/GHC/Types/SourceText.hs
+++ b/compiler/GHC/Types/SourceText.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Source text
--
@@ -95,7 +96,7 @@ For OverLitVal
-- Note [Literal source text],[Pragma source text]
data SourceText
- = SourceText String
+ = SourceText FastString
| NoSourceText
-- ^ For when code is generated, e.g. TH,
-- deriving. The pretty printer will then make
@@ -103,7 +104,7 @@ data SourceText
deriving (Data, Show, Eq )
instance Outputable SourceText where
- ppr (SourceText s) = text "SourceText" <+> text s
+ ppr (SourceText s) = text "SourceText" <+> ftext s
ppr NoSourceText = text "NoSourceText"
instance Binary SourceText where
@@ -124,7 +125,7 @@ instance Binary SourceText where
-- | Special combinator for showing string literals.
pprWithSourceText :: SourceText -> SDoc -> SDoc
pprWithSourceText NoSourceText d = d
-pprWithSourceText (SourceText src) _ = text src
+pprWithSourceText (SourceText src) _ = ftext src
------------------------------------------------
-- Literals
@@ -143,7 +144,7 @@ data IntegralLit = IL
deriving (Data, Show)
mkIntegralLit :: Integral a => a -> IntegralLit
-mkIntegralLit i = IL { il_text = SourceText (show i_integer)
+mkIntegralLit i = IL { il_text = SourceText (fsLit $ show i_integer)
, il_neg = i < 0
, il_value = i_integer }
where
@@ -153,9 +154,9 @@ mkIntegralLit i = IL { il_text = SourceText (show i_integer)
negateIntegralLit :: IntegralLit -> IntegralLit
negateIntegralLit (IL text neg value)
= case text of
- SourceText ('-':src) -> IL (SourceText src) False (negate value)
- SourceText src -> IL (SourceText ('-':src)) True (negate value)
- NoSourceText -> IL NoSourceText (not neg) (negate value)
+ SourceText (unconsFS -> Just ('-',src)) -> IL (SourceText src) False (negate value)
+ SourceText src -> IL (SourceText ('-' `consFS` src)) True (negate value)
+ NoSourceText -> IL NoSourceText (not neg) (negate value)
-- | Fractional Literal
--
@@ -206,7 +207,7 @@ rationalFromFractionalLit (FL _ _ i e expBase) =
mkRationalWithExponentBase i e expBase
mkTHFractionalLit :: Rational -> FractionalLit
-mkTHFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
+mkTHFractionalLit r = FL { fl_text = SourceText (fsLit $ show (realToFrac r::Double))
-- Converting to a Double here may technically lose
-- precision (see #15502). We could alternatively
-- convert to a Rational for the most accuracy, but
@@ -222,13 +223,14 @@ mkTHFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
negateFractionalLit :: FractionalLit -> FractionalLit
negateFractionalLit (FL text neg i e eb)
= case text of
- SourceText ('-':src) -> FL (SourceText src) False (negate i) e eb
- SourceText src -> FL (SourceText ('-':src)) True (negate i) e eb
+ SourceText (unconsFS -> Just ('-',src))
+ -> FL (SourceText src) False (negate i) e eb
+ SourceText src -> FL (SourceText ('-' `consFS` src)) True (negate i) e eb
NoSourceText -> FL NoSourceText (not neg) (negate i) e eb
-- | The integer should already be negated if it's negative.
integralFractionalLit :: Bool -> Integer -> FractionalLit
-integralFractionalLit neg i = FL { fl_text = SourceText (show i)
+integralFractionalLit neg i = FL { fl_text = SourceText (fsLit $ show i)
, fl_neg = neg
, fl_signi = i :% 1
, fl_exp = 0
@@ -238,7 +240,7 @@ integralFractionalLit neg i = FL { fl_text = SourceText (show i)
mkSourceFractionalLit :: String -> Bool -> Integer -> Integer
-> FractionalExponentBase
-> FractionalLit
-mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff
+mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText $ fsLit str) b (r :% 1) i ff
{- Note [fractional exponent bases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -258,7 +260,7 @@ instance Ord IntegralLit where
compare = compare `on` il_value
instance Outputable IntegralLit where
- ppr (IL (SourceText src) _ _) = text src
+ ppr (IL (SourceText src) _ _) = ftext src
ppr (IL NoSourceText _ value) = text (show value)
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index 72f6586094..af07bf00cd 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -196,12 +196,12 @@ instance Outputable (WarningTxt pass) where
ppr (WarningTxt _ lsrc ws)
= case unLoc lsrc of
NoSourceText -> pp_ws ws
- SourceText src -> text src <+> pp_ws ws <+> text "#-}"
+ SourceText src -> ftext src <+> pp_ws ws <+> text "#-}"
ppr (DeprecatedTxt lsrc ds)
= case unLoc lsrc of
NoSourceText -> pp_ws ds
- SourceText src -> text src <+> pp_ws ds <+> text "#-}"
+ SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
instance Binary (WarningTxt GhcRn) where
put_ bh (WarningTxt c s w) = do
diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
index 06fa9ea60d..9e9ae93c29 100644
--- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs
+++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
@@ -3,6 +3,7 @@
-- argument.
module Main where
+import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Types.SourceText
import Data.Data
@@ -46,32 +47,32 @@ testOneFile libdir fileName = do
doHsLit :: HsLit GhcPs -> [String]
doHsLit (HsChar (SourceText src) c)
- = ["HsChar [" ++ src ++ "] " ++ show c]
+ = ["HsChar [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsCharPrim (SourceText src) c)
- = ["HsCharPrim [" ++ src ++ "] " ++ show c]
+ = ["HsCharPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsString (SourceText src) c)
- = ["HsString [" ++ src ++ "] " ++ show c]
+ = ["HsString [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsStringPrim (SourceText src) c)
- = ["HsStringPrim [" ++ src ++ "] " ++ show c]
+ = ["HsStringPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsInt _ (IL (SourceText src) _ c))
- = ["HsInt [" ++ src ++ "] " ++ show c]
+ = ["HsInt [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsIntPrim (SourceText src) c)
- = ["HsIntPrim [" ++ src ++ "] " ++ show c]
+ = ["HsIntPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsWordPrim (SourceText src) c)
- = ["HsWordPrim [" ++ src ++ "] " ++ show c]
+ = ["HsWordPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsInt64Prim (SourceText src) c)
- = ["HsInt64Prim [" ++ src ++ "] " ++ show c]
+ = ["HsInt64Prim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsWord64Prim (SourceText src) c)
- = ["HsWord64Prim [" ++ src ++ "] " ++ show c]
+ = ["HsWord64Prim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsInteger (SourceText src) c _)
- = ["HsInteger [" ++ src ++ "] " ++ show c]
+ = ["HsInteger [" ++ unpackFS src ++ "] " ++ show c]
doHsLit _ = []
doOverLit :: OverLitVal -> [String]
doOverLit (HsIntegral (IL (SourceText src) _ c))
- = ["HsIntegral [" ++ src ++ "] " ++ show c]
+ = ["HsIntegral [" ++ unpackFS src ++ "] " ++ show c]
doOverLit (HsIsString (SourceText src) c)
- = ["HsIsString [" ++ src ++ "] " ++ show c]
+ = ["HsIsString [" ++ unpackFS src ++ "] " ++ show c]
doOverLit _ = []
pp a = showPprUnsafe a
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index f4d4defb5b..97e35b0ebb 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -477,7 +477,7 @@ class (Typeable a) => ExactPrint a where
printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m ()
printSourceText (NoSourceText) txt = printStringAdvance txt >> return ()
-printSourceText (SourceText txt) _ = printStringAdvance txt >> return ()
+printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return ()
-- ---------------------------------------------------------------------
@@ -564,7 +564,7 @@ printStringAtAAC capture (EpaDelta d cs) s = do
markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return ()
-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return ()
+markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return ()
-- ---------------------------------------------------------------------
@@ -658,21 +658,21 @@ markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}")
markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma)
markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
-markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
+markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt)
markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn])
markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt)
-markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt)
+markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt)
markAnnOpen' :: (Monad m, Monoid w)
=> Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation)
markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt
-markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt
+markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt
markAnnOpen'' :: (Monad m, Monoid w)
=> EpaLocation -> SourceText -> String -> EP w m EpaLocation
markAnnOpen'' el NoSourceText txt = printStringAtAA el txt
-markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt
+markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt
-- ---------------------------------------------------------------------
{-
@@ -1795,7 +1795,7 @@ instance ExactPrint (RuleDecls GhcPs) where
an0 <-
case src of
NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES")
- SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt)
+ SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just $ unpackFS srcTxt)
rules' <- markAnnotated rules
an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")
return (HsRules (an1,src) rules')
@@ -2715,7 +2715,7 @@ instance ExactPrint (HsExpr GhcPs) where
printStringAtLsDelta (SameLine 0) "#"
case src of
NoSourceText -> printStringAtLsDelta (SameLine 0) (unpackFS l)
- SourceText txt -> printStringAtLsDelta (SameLine 0) txt
+ SourceText txt -> printStringAtLsDelta (SameLine 0) (unpackFS txt)
return x
exact x@(HsIPVar _ (HsIPName n))
@@ -2727,7 +2727,7 @@ instance ExactPrint (HsExpr GhcPs) where
HsFractional (FL { fl_text = src }) -> src
HsIsString src _ -> src
case str of
- SourceText s -> printStringAdvance s >> return ()
+ SourceText s -> printStringAdvance (unpackFS s) >> return ()
NoSourceText -> withPpr x >> return ()
return x
@@ -3909,7 +3909,7 @@ instance ExactPrint (HsType GhcPs) where
NoSourceText -> return an
SourceText src -> do
debugM $ "HsBangTy: src=" ++ showAst src
- an0 <- markEpAnnLMS an lid AnnOpen (Just src)
+ an0 <- markEpAnnLMS an lid AnnOpen (Just $ unpackFS src)
an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}")
debugM $ "HsBangTy: done unpackedness"
return an1
@@ -4678,7 +4678,7 @@ instance ExactPrint (HsOverLit GhcPs) where
HsIsString src _ -> src
in
case str of
- SourceText s -> printStringAdvance s >> return ol
+ SourceText s -> printStringAdvance (unpackFS s) >> return ol
NoSourceText -> return ol
-- ---------------------------------------------------------------------
@@ -4710,11 +4710,11 @@ hsLit2String lit =
toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String
toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix
-toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix
+toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix
sourceTextToString :: SourceText -> String -> String
sourceTextToString NoSourceText alt = alt
-sourceTextToString (SourceText txt) _ = txt
+sourceTextToString (SourceText txt) _ = unpackFS txt
-- ---------------------------------------------------------------------
View Lorry Controller Status