[Git][ghc/ghc][master] Minor SDoc-related cleanup
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Oct 28 04:50:21 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ad612f55 by Krzysztof Gogolewski at 2022-10-28T00:50:00-04:00
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
- - - - -
22 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/CLabel.hs-boot
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/Dwarf/Types.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/Linker/ExtraObj.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Stg/Lift/Monad.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Types/ForeignStubs.hs
- compiler/GHC/Utils/Outputable.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
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
=====================================
compiler/GHC/Cmm/CLabel.hs-boot
=====================================
@@ -5,5 +5,4 @@ import GHC.Platform
data CLabel
-pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
-
+pprCLabel :: Platform -> CLabel -> SDoc
=====================================
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
=====================================
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
=====================================
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"
=====================================
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)
=====================================
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
=====================================
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 ";"
=====================================
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)
=====================================
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)
=====================================
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)))
=====================================
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
=====================================
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= " <>
=====================================
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
=====================================
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
=====================================
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)
=====================================
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
=====================================
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}
=====================================
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
=====================================
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
]
=====================================
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
=====================================
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))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad612f555821a44260e5d9654f940b71f5180817
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad612f555821a44260e5d9654f940b71f5180817
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221028/29c8fd80/attachment-0001.html>
More information about the ghc-commits
mailing list