diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2022-10-25 21:20:37 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-10-28 00:50:00 -0400 |
commit | ad612f555821a44260e5d9654f940b71f5180817 (patch) | |
tree | c5601914b79e3d3872ce0e4844d6910cfd00ab43 | |
parent | 750846cd2c51613d2bbd0029a304d07fae2c2972 (diff) | |
download | haskell-ad612f555821a44260e5d9654f940b71f5180817.tar.gz |
Minor SDoc-related cleanup
* Rename pprCLabel to pprCLabelStyle, and use the name pprCLabel
for a function using CStyle (analogous to pprAsmLabel)
* Move LabelStyle to the CLabel module, it no longer needs to be in Outputable.
* Move calls to 'text' right next to literals, to make sure the text/str
rule is triggered.
* Remove FastString/String roundtrip in Tc.Deriv.Generate
* Introduce showSDocForUser', which abstracts over a pattern in
GHCi.UI
-rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 35 | ||||
-rw-r--r-- | compiler/GHC/Cmm/CLabel.hs-boot | 3 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Parser.y | 2 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/Dwarf/Types.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/CmmToC.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/CmmToLlvm/Base.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/SetLevels.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Tidy/StaticPtrTable.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Linker/ExtraObj.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 44 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lift/Monad.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/InfoTableProv.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Deriv.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 36 | ||||
-rw-r--r-- | compiler/GHC/Types/ForeignCall.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Types/ForeignStubs.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 15 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 59 |
22 files changed, 138 insertions, 134 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 6d4397e62b..bf4214fed2 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -455,7 +455,7 @@ data ForeignLabelSource -- The regular Outputable instance only shows the label name, and not its other info. -- pprDebugCLabel :: Platform -> CLabel -> SDoc -pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra +pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra where extra = case lbl of IdLabel _ _ info @@ -1416,18 +1416,33 @@ allocation. Take care if you want to remove them! -} +-- | Style of label pretty-printing. +-- +-- When we produce C sources or headers, we have to take into account that C +-- compilers transform C labels when they convert them into symbols. For +-- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for +-- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style +-- or Asm style. +-- +data LabelStyle + = CStyle -- ^ C label style (used by C and LLVM backends) + | AsmStyle -- ^ Asm label style (used by NCG backend) + pprAsmLabel :: Platform -> CLabel -> SDoc -pprAsmLabel platform lbl = pprCLabel platform AsmStyle lbl +pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl + +pprCLabel :: Platform -> CLabel -> SDoc +pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl instance OutputableP Platform CLabel where {-# INLINE pdoc #-} -- see Note [Bangs in CLabel] pdoc !platform lbl = getPprStyle $ \pp_sty -> case pp_sty of - PprDump{} -> pprCLabel platform CStyle lbl - _ -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl) + PprDump{} -> pprCLabel platform lbl + _ -> pprPanic "Labels in code should be printed with pprCLabel or pprAsmLabel" (pprCLabel platform lbl) -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc -pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] +pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc +pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel] let !use_leading_underscores = platformLeadingUnderscore platform @@ -1456,11 +1471,11 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] -> asmTempLabelPrefix platform <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabel platform sty l + _other -> pprCLabelStyle platform sty l <> ftext suf DynamicLinkerLabel info lbl - -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl) + -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl) PicBaseLabel -> text "1b" @@ -1473,7 +1488,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] optional `_` (underscore) because this is how you mark non-temp symbols on some platforms (Darwin) -} - maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp" + maybe_underscore $ text "dsp_" <> pprCLabelStyle platform sty lbl <> text "_dsp" StringLitLabel u -> maybe_underscore $ pprUniqueAlways u <> text "_str" @@ -1556,7 +1571,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] CC_Label cc -> maybe_underscore $ ppr cc CCS_Label ccs -> maybe_underscore $ ppr ccs - IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform CStyle l <> text "_" <> ppr m <> text "_ipe") + IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> ppr m <> text "_ipe") ModuleLabel mod kind -> maybe_underscore $ ppr mod <> text "_" <> ppr kind CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot index 8fb1b74423..cca3ce684e 100644 --- a/compiler/GHC/Cmm/CLabel.hs-boot +++ b/compiler/GHC/Cmm/CLabel.hs-boot @@ -5,5 +5,4 @@ import GHC.Platform data CLabel -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc - +pprCLabel :: Platform -> CLabel -> SDoc diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 656de66848..553dd59f24 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -450,7 +450,7 @@ cmmproc :: { CmmParse () } platform <- getPlatform; ctx <- getContext; formals <- sequence (fromMaybe [] $3); - withName (showSDocOneLine ctx (pprCLabel platform CStyle entry_ret_label)) + withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label)) $4; return (entry_ret_label, info, stk_formals, formals) } let do_layout = isJust $3 diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index 236ddb5ffc..55eb0246bf 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -163,8 +163,8 @@ pprDwarfInfo platform haveSrc d -- | Print a CLabel name in a ".stringz \"LABEL\"" pprLabelString :: Platform -> CLabel -> SDoc pprLabelString platform label = - pprString' -- we don't need to escape the string as labels don't contain exotic characters - $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm) + pprString' -- we don't need to escape the string as labels don't contain exotic characters + $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm) -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 44d4657052..c492e6f1a3 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -88,7 +88,7 @@ pprTop platform = \case blankLine, extern_decls, (if (externallyVisibleCLabel clbl) - then mkFN_ else mkIF_) (pprCLabel platform CStyle clbl) <+> lbrace, + then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace, nest 8 temp_decls, vcat (map (pprBBlock platform) blocks), rbrace ] @@ -110,14 +110,14 @@ pprTop platform = \case (CmmData section (CmmStaticsRaw lbl [CmmString str])) -> pprExternDecl platform lbl $$ hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl, + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl, text "[] = ", pprStringInCStyle str, semi ] (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) -> pprExternDecl platform lbl $$ hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl, + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl, brackets (int size), semi ] @@ -153,7 +153,7 @@ pprWordArray platform is_ro lbl ds = -- TODO: align closures only pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" - , space, pprCLabel platform CStyle lbl, text "[]" + , space, pprCLabel platform lbl, text "[]" -- See Note [StgWord alignment] , pprAlignment (wordWidth platform) , text "= {" ] @@ -245,7 +245,7 @@ pprStmt platform stmt = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - pprCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs + pprCall platform (pprCLabel platform lbl) cconv hresults hargs -- stdcall functions must be declared with -- a function type, otherwise the C compiler -- doesn't add the @n suffix to the label. We @@ -254,7 +254,7 @@ pprStmt platform stmt = | CmmNeverReturns <- ret -> pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();" | not (isMathFun lbl) -> - pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs + pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs _ -> pprCall platform cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary. @@ -595,7 +595,7 @@ pprLit platform lit = case lit of -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i where - pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl + pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl pprLit1 :: Platform -> CmmLit -> SDoc pprLit1 platform lit = case lit of @@ -1208,7 +1208,7 @@ pprExternDecl platform lbl | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz | otherwise = - hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");" + hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");" -- occasionally useful to see label type -- , text "/* ", pprDebugCLabel lbl, text " */" ] @@ -1231,7 +1231,7 @@ pprExternDecl platform lbl -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) stdcall_decl sz = - text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl + text "extern __attribute__((stdcall)) void " <> pprCLabel platform lbl <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform)))) <> semi @@ -1501,8 +1501,8 @@ pprCtorArray platform initOrFini lbls = <> text "void _hs_" <> attribute <> text "()" <> braces body where - body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ] - decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ] + body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ] + decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ] attribute = case initOrFini of IsInitArray -> text "constructor" IsFiniArray -> text "destructor" diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index d891fd17b3..17fa7394a7 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -440,7 +440,7 @@ strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do ctx <- llvmCgContext <$> getConfig platform <- getPlatform - let sdoc = pprCLabel platform CStyle lbl + let sdoc = pprCLabel platform lbl str = Outp.showSDocOneLine ctx sdoc return (fsLit str) diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 5ac447883a..da328da1ce 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -95,7 +95,7 @@ import GHC.Types.Literal ( litIsTrivial ) import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) import GHC.Types.Name ( getOccName, mkSystemVarName ) -import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) import GHC.Types.Unique.Supply @@ -1697,9 +1697,9 @@ newPolyBndrs dest_lvl mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id transfer_join_info bndr $ - mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty + mkSysLocal str uniq (idMult bndr) poly_ty where - str = "poly_" ++ occNameString (getOccName bndr) + str = fsLit "poly_" `appendFS` occNameFS (getOccName bndr) poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr)) -- If we are floating a join point to top level, it stops being diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 09315c4f05..448c4c864e 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -330,7 +330,7 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs) = {-# SCC profilingInitCode #-} initializerCStub platform fn_name decls body where - pdocC = pprCLabel platform CStyle + pdocC = pprCLabel platform fn_name = mkInitializerStubLabel this_mod "prof_init" decls = vcat $ map emit_cc_decl local_CCs @@ -378,7 +378,7 @@ ipInitCode do_info_table platform this_mod body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi - ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod) + ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod) ipe_buffer_decl = text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";" diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index a130fed062..c2e69a4087 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -2481,7 +2481,7 @@ hscTidy hsc_env guts = do -- on, print now unless (logHasDumpFlag logger Opt_D_dump_simpl) $ putDumpFileMaybe logger Opt_D_dump_rules - (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules")) + "Tidy Core rules" FormatText (pprRulesForUser tidy_rules) diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index eb708cd295..6e8814321c 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -66,7 +66,7 @@ module GHC.Hs.Utils( spanHsLocaLBinds, -- * Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit, mkHsCharPrimLit, -- * Patterns @@ -454,6 +454,9 @@ mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2 mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) +mkHsStringFS :: FastString -> HsLit (GhcPass p) +mkHsStringFS s = HsString NoSourceText s + mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index cec5a581de..9e2619db65 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -126,7 +126,7 @@ hpcInitCode platform this_mod (HpcInfo tickCount hashNo) tickboxes ])) <> semi - tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod) + tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ BS.unpack $ bytesFS (moduleNameFS (moduleName this_mod))) diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index 63297f4ad2..cf37095041 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -249,11 +249,11 @@ sptModuleInitCode platform this_mod entries = [ text "static StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi $$ text "extern StgPtr " - <> (pprCLabel platform CStyle $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + <> (pprCLabel platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma [ char 'k' <> int i - , char '&' <> pprCLabel platform CStyle (mkClosureLabel (idName n) (idCafInfo n)) + , char '&' <> pprCLabel platform (mkClosureLabel (idName n) (idCafInfo n)) ] ) <> semi diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index 90cf2466e5..97f2bd5b07 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -124,13 +124,13 @@ mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do text " __conf.rts_opts_enabled = " <> text (show (rtsOptsEnabled dflags)) <> semi, text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, + <> (if rtsOptsSuggestions dflags + then text "true" + else text "false") <> semi, text "__conf.keep_cafs = " - <> text (if gopt Opt_KeepCAFs dflags - then "true" - else "false") <> semi, + <> (if gopt Opt_KeepCAFs dflags + then text "true" + else text "false") <> semi, case rtsOpts dflags of Nothing -> Outputable.empty Just opts -> text " __conf.rts_opts= " <> diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index f2f8bfd769..1263d5104b 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -77,20 +77,20 @@ instance Diagnostic PsMessage where PsWarnTransitionalLayout reason -> mkSimpleDecorated $ text "transitional layout will not be accepted in the future:" - $$ text (case reason of - TransLayout_Where -> "`where' clause at the same depth as implicit layout block" - TransLayout_Pipe -> "`|' at the same depth as implicit layout block" + $$ (case reason of + TransLayout_Where -> text "`where' clause at the same depth as implicit layout block" + TransLayout_Pipe -> text "`|' at the same depth as implicit layout block" ) PsWarnOperatorWhitespaceExtConflict sym -> let mk_prefix_msg extension_name syntax_meaning = text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym) - <+> text "would denote" <+> text syntax_meaning - $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.") + <+> text "would denote" <+> syntax_meaning + $$ nest 2 (text "were the" <+> extension_name <+> text "extension enabled.") in mkSimpleDecorated $ case sym of - OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "LinearTypes" "a multiplicity annotation" - OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "TemplateHaskell" "an untyped splice" - OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "TemplateHaskell" "a typed splice" + OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg (text "LinearTypes") (text "a multiplicity annotation") + OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg (text "TemplateHaskell") (text "an untyped splice") + OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg (text "TemplateHaskell") (text "a typed splice") PsWarnOperatorWhitespace sym occ_type -> let mk_msg occ_type_str = text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) @@ -124,21 +124,21 @@ instance Diagnostic PsMessage where PsErrLexer err kind -> mkSimpleDecorated $ hcat - [ text $ case err of - LexError -> "lexical error" - LexUnknownPragma -> "unknown pragma" - LexErrorInPragma -> "lexical error in pragma" - LexNumEscapeRange -> "numeric escape sequence out of range" - LexStringCharLit -> "lexical error in string/character literal" - LexStringCharLitEOF -> "unexpected end-of-file in string/character literal" - LexUnterminatedComment -> "unterminated `{-'" - LexUnterminatedOptions -> "unterminated OPTIONS pragma" - LexUnterminatedQQ -> "unterminated quasiquotation" + [ case err of + LexError -> text "lexical error" + LexUnknownPragma -> text "unknown pragma" + LexErrorInPragma -> text "lexical error in pragma" + LexNumEscapeRange -> text "numeric escape sequence out of range" + LexStringCharLit -> text "lexical error in string/character literal" + LexStringCharLitEOF -> text "unexpected end-of-file in string/character literal" + LexUnterminatedComment -> text "unterminated `{-'" + LexUnterminatedOptions -> text "unterminated OPTIONS pragma" + LexUnterminatedQQ -> text "unterminated quasiquotation" - , text $ case kind of - LexErrKind_EOF -> " at end of input" - LexErrKind_UTF8 -> " (UTF-8 decoding error)" - LexErrKind_Char c -> " at character " ++ show c + , case kind of + LexErrKind_EOF -> text " at end of input" + LexErrKind_UTF8 -> text " (UTF-8 decoding error)" + LexErrKind_Char c -> text $ " at character " ++ show c ] PsErrParse token _details | null token diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index a07c89b513..8e16dd922c 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -276,13 +276,13 @@ withSubstBndrs = runContT . traverse (ContT . withSubstBndr) withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a withLiftedBndr abs_ids bndr inner = do uniq <- getUniqueM - let str = "$l" ++ occNameString (getOccName bndr) + let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr) let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) let bndr' -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal (mkFastString str) uniq Many + . mkSysLocal str uniq Many $ ty LiftM $ RWS.local (\e -> e diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs index 11e5552af8..22fd2308b4 100644 --- a/compiler/GHC/StgToCmm/InfoTableProv.hs +++ b/compiler/GHC/StgToCmm/InfoTableProv.hs @@ -64,7 +64,7 @@ emitIpeBufferListNode this_mod ents = do toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt toCgIPE platform ctx module_name ipe = do - table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe)) + table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe)) closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe) type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe let label_str = maybe "" snd (infoTableProv ipe) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index feefb05ac1..8284aba4f7 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -201,7 +201,6 @@ tcDeriving deriv_infos deriv_decls ; famInsts2 <- concatMapM genFamInsts infer_specs ; let famInsts = famInsts1 ++ famInsts2 - ; dflags <- getDynFlags ; logger <- getLogger -- We must put all the derived type family instances (from both @@ -229,7 +228,7 @@ tcDeriving deriv_infos deriv_decls ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds) ; loc <- getSrcSpanM - ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs) + ; let aux_binds = genAuxBinds loc (unionManyBags aux_specs) ; let infer_inst_infos = map fstOf3 infer_inst_binds ; let inst_infos = given_inst_infos ++ infer_inst_infos diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index e51eee9841..259d7ce20f 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -54,7 +54,6 @@ import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.SourceText -import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Builtin.Names @@ -1170,14 +1169,14 @@ gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon}) where lbl_str = unpackFS lbl mk_read_field read_field_rdr lbl - = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] + = nlHsApps read_field_rdr [nlHsLit (mkHsStringFS lbl)] read_field | isSym lbl_str - = mk_read_field readSymField_RDR lbl_str + = mk_read_field readSymField_RDR lbl | Just (ss, '#') <- snocView lbl_str -- #14918 - = mk_read_field readFieldHash_RDR ss + = mk_read_field readFieldHash_RDR (mkFastString ss) | otherwise - = mk_read_field readField_RDR lbl_str + = mk_read_field readField_RDR lbl {- ************************************************************************ @@ -2156,9 +2155,9 @@ fiddling around. -- | Generate the full code for an auxiliary binding. -- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@. -genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec +genAuxBindSpecOriginal :: SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) -genAuxBindSpecOriginal dflags loc spec +genAuxBindSpecOriginal loc spec = (gen_bind spec, L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)] (genAuxBindSpecSig loc spec))) @@ -2183,11 +2182,10 @@ genAuxBindSpecOriginal dflags loc spec = mkHsVarBind loc dataT_RDR rhs where tc_name = tyConName tycon - tc_name_string = occNameString (getOccName tc_name) - definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name)) - ctx = initDefaultSDocContext dflags + tc_name_string = occNameFS (getOccName tc_name) + definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name)) rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string))) + `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string])) `nlHsApp` nlList (map nlHsVar dataC_RDRs) gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) @@ -2197,12 +2195,12 @@ genAuxBindSpecOriginal dflags loc spec constr_args = [ nlHsVar dataT_RDR -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- Constructor name + , nlHsLit (mkHsStringFS (occNameFS dc_occ)) -- Constructor name , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag , nlList labels -- Field labels , nlHsVar fixity ] -- Fixity - labels = map (nlHsLit . mkHsString . unpackFS . field_label . flLabel) + labels = map (nlHsLit . mkHsStringFS . field_label . flLabel) (dataConFieldLabels dc) dc_occ = getOccName dc is_infix = isDataSymOcc dc_occ @@ -2243,9 +2241,9 @@ genAuxBindSpecSig loc spec = case spec of -- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary -- bindings based on the declarative descriptions in the supplied -- 'AuxBindSpec's. See @Note [Auxiliary binders]@. -genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec +genAuxBinds :: SrcSpan -> Bag AuxBindSpec -> Bag (LHsBind GhcPs, LSig GhcPs) -genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) +genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) where -- Perform a CSE-like pass over the generated auxiliary bindings to avoid -- code duplication, as described in @@ -2259,7 +2257,7 @@ genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) case lookupOccEnv original_rdr_name_env spec_occ of Nothing -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name - , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag ) + , genAuxBindSpecOriginal loc spec `consBag` spec_bag ) Just original_rdr_name -> ( original_rdr_name_env , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag ) @@ -2363,7 +2361,7 @@ mkRdrFunBindSE arity fun@(L loc fun_rdr) matches (replicate arity nlWildPat) (error_Expr str) emptyLocalBinds] else matches - str = "Void " ++ occNameString (rdrNameOcc fun_rdr) + str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr) box :: String -- The class involved @@ -2550,8 +2548,8 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! -error_Expr :: String -> LHsExpr GhcPs -error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) +error_Expr :: FastString -> LHsExpr GhcPs +error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string)) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs index 41918f34db..e4c8018bb7 100644 --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -219,8 +219,8 @@ instance Outputable CCallSpec where | otherwise = text "_unsafe" ppr_fun (StaticTarget st lbl mPkgId isFun) - = text (if isFun then "__ffi_static_ccall" - else "__ffi_static_ccall_value") + = (if isFun then text "__ffi_static_ccall" + else text "__ffi_static_ccall_value") <> gc_suf <+> (case mPkgId of Nothing -> empty diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs index b92bfd9b64..f366ddbf4a 100644 --- a/compiler/GHC/Types/ForeignStubs.hs +++ b/compiler/GHC/Types/ForeignStubs.hs @@ -44,7 +44,7 @@ functionCStub platform clbl declarations body = where body' = vcat [ declarations - , hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"] + , hsep [text "void", pprCLabel platform clbl, text "(void)"] , braces body ] diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 1c6126d208..4e174ff4d0 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -83,7 +83,7 @@ module GHC.Utils.Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle(..), LabelStyle(..), PrintUnqualified(..), + PprStyle(..), PrintUnqualified(..), QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, @@ -173,19 +173,6 @@ data PprStyle | PprCode -- ^ Print code; either C or assembler --- | Style of label pretty-printing. --- --- When we produce C sources or headers, we have to take into account that C --- compilers transform C labels when they convert them into symbols. For --- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for --- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style --- or Asm style. --- -data LabelStyle - = CStyle -- ^ C label style (used by C and LLVM backends) - | AsmStyle -- ^ Asm label style (used by NCG backend) - deriving (Eq,Ord,Show) - data Depth = AllTheWay | PartWay Int -- ^ 0 => stop diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 519049cad7..f697073763 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -298,6 +298,20 @@ flagWordBreakChars :: String flagWordBreakChars = " \t\n" +showSDocForUser' :: GHC.GhcMonad m => SDoc -> m String +showSDocForUser' doc = do + dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession + unqual <- GHC.getPrintUnqual + pure $ showSDocForUser dflags unit_state unqual doc + +showSDocForUserQualify :: GHC.GhcMonad m => SDoc -> m String +showSDocForUserQualify doc = do + dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession + pure $ showSDocForUser dflags unit_state alwaysQualify doc + + keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) keepGoing a str = keepGoing' (lift . a) str @@ -1572,11 +1586,10 @@ help _ = do info :: GHC.GhcMonad m => Bool -> String -> m () info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'") info allInfo s = handleSourceError GHC.printException $ do - unqual <- GHC.getPrintUnqual - dflags <- getDynFlags - sdocs <- mapM (infoThing allInfo) (words s) - unit_state <- hsc_units <$> GHC.getSession - mapM_ (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs + forM_ (words s) $ \thing -> do + sdoc <- infoThing allInfo thing + rendered <- showSDocForUser' sdoc + liftIO (putStrLn rendered) infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc infoThing allInfo str = do @@ -1906,10 +1919,8 @@ docCmd s = do let sdocs = pprDocs docs sdocs' = vcat (intersperse (text "") sdocs) - unqual <- GHC.getPrintUnqual - dflags <- getDynFlags - unit_state <- hsc_units <$> GHC.getSession - (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs' + sdoc <- showSDocForUser' sdocs' + liftIO (putStrLn sdoc) data DocComponents = DocComponents @@ -2264,9 +2275,6 @@ keepPackageImports = filterM is_pkg_import modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m () modulesLoadedMsg ok mods = do dflags <- getDynFlags - unit_state <- hsc_units <$> GHC.getSession - unqual <- GHC.getPrintUnqual - msg <- if gopt Opt_ShowLoadedModules dflags then do mod_names <- mapM mod_name mods @@ -2278,8 +2286,9 @@ modulesLoadedMsg ok mods = do return $ status <> text "," <+> speakNOf (length mods) (text "module") <+> "loaded." - when (verbosity dflags > 0) $ - liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual msg + when (verbosity dflags > 0) $ do + rendered_msg <- showSDocForUser' msg + liftIO $ putStrLn rendered_msg where status = case ok of Failed -> text "Failed" @@ -2302,9 +2311,8 @@ runExceptGhciMonad act = handleSourceError GHC.printException $ runExceptT act where handleErr sdoc = do - dflags <- getDynFlags - unit_state <- hsc_units <$> GHC.getSession - liftIO . hPutStrLn stderr . showSDocForUser dflags unit_state alwaysQualify $ sdoc + rendered <- showSDocForUserQualify sdoc + liftIO $ hPutStrLn stderr rendered failIfExprEvalMode -- | Inverse of 'runExceptT' for \"pure\" computations @@ -2369,11 +2377,8 @@ allTypesCmd _ = runExceptGhciMonad $ do where printSpan span' | Just ty <- spaninfoType span' = do - hsc_env <- GHC.getSession - let tyInfo = unwords . words $ - showSDocForUser (hsc_dflags hsc_env) - (hsc_units hsc_env) - alwaysQualify (pprSigmaType ty) + tyInfo <- (unwords . words) <$> + showSDocForUserQualify (pprSigmaType ty) liftIO . putStrLn $ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo | otherwise = return () @@ -2618,15 +2623,11 @@ guessCurrentModule cmd -- with sorted, sort items alphabetically browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m () browseModule bang modl exports_only = do - -- :browse reports qualifiers wrt current context - unqual <- GHC.getPrintUnqual - mb_mod_info <- GHC.getModuleInfo modl case mb_mod_info of Nothing -> throwGhcException (CmdLineError ("unknown module: " ++ GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do - dflags <- getDynFlags let names | exports_only = GHC.modInfoExports mod_info | otherwise = GHC.modInfoTopLevelScope mod_info @@ -2685,8 +2686,10 @@ browseModule bang modl exports_only = do prettyThings = map pretty things prettyThings' | bang = annotate $ zip modNames prettyThings | otherwise = prettyThings - unit_state <- hsc_units <$> GHC.getSession - liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual (vcat prettyThings') + + -- :browse reports qualifiers wrt current context + rendered_things <- showSDocForUser' (vcat prettyThings') + liftIO $ putStrLn rendered_things -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) |