From 90e69d5d167b9d6cd63b04e42f8af375dc4b307f Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Thu, 4 May 2023 05:30:13 +0530 Subject: 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. --- compiler/GHC/Core/Opt/Simplify/Iteration.hs | 2 +- compiler/GHC/Core/Opt/WorkWrap.hs | 6 +- compiler/GHC/Hs/Binds.hs | 4 +- compiler/GHC/Hs/Decls.hs | 4 +- compiler/GHC/Hs/Dump.hs | 4 +- compiler/GHC/Hs/Expr.hs | 4 +- compiler/GHC/Hs/ImpExp.hs | 2 +- compiler/GHC/Parser/Lexer.x | 76 ++++++++++++---------- compiler/GHC/Parser/PostProcess.hs | 5 +- compiler/GHC/ThToHs.hs | 42 ++++++------ compiler/GHC/Types/Basic.hs | 2 +- compiler/GHC/Types/SourceText.hs | 28 ++++---- compiler/GHC/Unit/Module/Warnings.hs | 4 +- .../tests/ghc-api/annotations-literals/parsed.hs | 25 +++---- utils/check-exact/ExactPrint.hs | 26 ++++---- 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 -- --------------------------------------------------------------------- -- cgit v1.2.1