[Git][ghc/ghc][master] 3 commits: Refactor CLabel pretty-printing
Marge Bot
gitlab at gitlab.haskell.org
Thu Sep 24 00:43:58 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
667d6355 by Sylvain Henry at 2020-09-23T20:43:48-04:00
Refactor CLabel pretty-printing
* Don't depend on the selected backend to know if we print Asm or C
labels: we already have PprStyle to determine this. Moreover even when
a native backend is used (NCG, LLVM) we may want to C headers
containing pretty-printed labels, so it wasn't a good predicate
anyway.
* Make pretty-printing code clearer and avoid partiality
- - - - -
a584366b by Sylvain Henry at 2020-09-23T20:43:48-04:00
Remove sdocWithDynFlags (fix #10143)
- - - - -
a997fa01 by Sylvain Henry at 2020-09-23T20:43:48-04:00
Preliminary work towards removing DynFlags -> Driver.Ppr dependency
- - - - -
10 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Dwarf/Types.hs
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -17,8 +17,9 @@ module GHC.Cmm.CLabel (
CLabel, -- abstract type
NeedExternDecl (..),
ForeignLabelSource(..),
- pprDebugCLabel,
+ DynamicLinkerLabelInfo(..),
+ -- * Constructors
mkClosureLabel,
mkSRTLabel,
mkInfoTableLabel,
@@ -68,7 +69,6 @@ module GHC.Cmm.CLabel (
mkSelectorInfoLabel,
mkSelectorEntryLabel,
-
mkCmmInfoLabel,
mkCmmEntryLabel,
mkCmmRetInfoLabel,
@@ -77,44 +77,52 @@ module GHC.Cmm.CLabel (
mkCmmDataLabel,
mkRtsCmmDataLabel,
mkCmmClosureLabel,
-
mkRtsApFastLabel,
-
mkPrimCallLabel,
-
mkForeignLabel,
- addLabelSize,
-
- foreignLabelStdcallInfo,
- isBytesLabel,
- isForeignLabel,
- isSomeRODataLabel,
- isStaticClosureLabel,
- mkCCLabel, mkCCSLabel,
-
- DynamicLinkerLabelInfo(..),
+ mkCCLabel,
+ mkCCSLabel,
mkDynamicLinkerLabel,
- dynamicLinkerLabelInfo,
-
mkPicBaseLabel,
mkDeadStripPreventer,
-
mkHpcTicksLabel,
-- * Predicates
hasCAF,
- needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
+ needsCDecl,
+ maybeLocalBlockLabel,
+ externallyVisibleCLabel,
isMathFun,
- isCFunctionLabel, isGcPtrLabel, labelDynamic,
- isLocalCLabel, mayRedirectTo,
+ isCFunctionLabel,
+ isGcPtrLabel,
+ labelDynamic,
+ isLocalCLabel,
+ mayRedirectTo,
+ isInfoTableLabel,
+ isConInfoTableLabel,
+ isIdLabel,
+ isTickyLabel,
+ hasHaskellName,
+ isBytesLabel,
+ isForeignLabel,
+ isSomeRODataLabel,
+ isStaticClosureLabel,
-- * Conversions
- toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
+ toClosureLbl,
+ toSlowEntryLbl,
+ toEntryLbl,
+ toInfoLbl,
- pprCLabel, pprCLabel_LLVM, pprCLabel_NCG, pprCLabel_ViaC,
- isInfoTableLabel,
- isConInfoTableLabel,
- isIdLabel, isTickyLabel
+ -- * Pretty-printing
+ LabelStyle (..),
+ pprDebugCLabel,
+ pprCLabel,
+
+ -- * Others
+ dynamicLinkerLabelInfo,
+ addLabelSize,
+ foreignLabelStdcallInfo
) where
#include "HsVersions.h"
@@ -133,7 +141,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Driver.Session
-import GHC.Driver.Backend
import GHC.Platform
import GHC.Types.Unique.Set
import GHC.Utils.Misc
@@ -403,23 +410,22 @@ data ForeignLabelSource
-- The regular Outputable instance only shows the label name, and not its other info.
--
pprDebugCLabel :: Platform -> CLabel -> SDoc
-pprDebugCLabel platform lbl
- = case lbl of
- IdLabel _ _ info-> pprCLabel_other platform lbl
- <> (parens $ text "IdLabel"
- <> whenPprDebug (text ":" <> text (show info)))
- CmmLabel pkg _ext _name _info
- -> pprCLabel_other platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra
+ where
+ extra = case lbl of
+ IdLabel _ _ info
+ -> text "IdLabel" <> whenPprDebug (text ":" <> text (show info))
+
+ CmmLabel pkg _ext _name _info
+ -> text "CmmLabel" <+> ppr pkg
- RtsLabel{} -> pprCLabel_other platform lbl <> (parens $ text "RtsLabel")
+ RtsLabel{}
+ -> text "RtsLabel"
- ForeignLabel _name mSuffix src funOrData
- -> pprCLabel_other platform lbl <> (parens $ text "ForeignLabel"
- <+> ppr mSuffix
- <+> ppr src
- <+> ppr funOrData)
+ ForeignLabel _name mSuffix src funOrData
+ -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData
- _ -> pprCLabel_other platform lbl <> (parens $ text "other CLabel")
+ _ -> text "other CLabel"
data IdLabelInfo
@@ -760,13 +766,13 @@ toClosureLbl :: Platform -> CLabel -> CLabel
toClosureLbl platform lbl = case lbl of
IdLabel n c _ -> IdLabel n c Closure
CmmLabel m ext str _ -> CmmLabel m ext str CmmClosure
- _ -> pprPanic "toClosureLbl" (pprCLabel_other platform lbl)
+ _ -> pprPanic "toClosureLbl" (pprDebugCLabel platform lbl)
toSlowEntryLbl :: Platform -> CLabel -> CLabel
toSlowEntryLbl platform lbl = case lbl of
IdLabel n _ BlockInfoTable -> pprPanic "toSlowEntryLbl" (ppr n)
IdLabel n c _ -> IdLabel n c Slow
- _ -> pprPanic "toSlowEntryLbl" (pprCLabel_other platform lbl)
+ _ -> pprPanic "toSlowEntryLbl" (pprDebugCLabel platform lbl)
toEntryLbl :: Platform -> CLabel -> CLabel
toEntryLbl platform lbl = case lbl of
@@ -777,7 +783,7 @@ toEntryLbl platform lbl = case lbl of
IdLabel n c _ -> IdLabel n c Entry
CmmLabel m ext str CmmInfo -> CmmLabel m ext str CmmEntry
CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet
- _ -> pprPanic "toEntryLbl" (pprCLabel_other platform lbl)
+ _ -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl)
toInfoLbl :: Platform -> CLabel -> CLabel
toInfoLbl platform lbl = case lbl of
@@ -786,7 +792,7 @@ toInfoLbl platform lbl = case lbl of
IdLabel n c _ -> IdLabel n c InfoTable
CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo
CmmLabel m ext str CmmRet -> CmmLabel m ext str CmmRetInfo
- _ -> pprPanic "CLabel.toInfoLbl" (pprCLabel_other platform lbl)
+ _ -> pprPanic "CLabel.toInfoLbl" (pprDebugCLabel platform lbl)
hasHaskellName :: CLabel -> Maybe Name
hasHaskellName (IdLabel n _ _) = Just n
@@ -1214,36 +1220,32 @@ and are not externally visible.
-}
instance OutputableP Platform CLabel where
- pdoc platform lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) platform lbl)
-
-pprCLabel :: Backend -> Platform -> CLabel -> SDoc
-pprCLabel bcknd platform lbl =
- case bcknd of
- NCG -> pprCLabel_NCG platform lbl
- LLVM -> pprCLabel_LLVM platform lbl
- ViaC -> pprCLabel_ViaC platform lbl
- _ -> pprCLabel_other platform lbl
-
-pprCLabel_LLVM :: Platform -> CLabel -> SDoc
-pprCLabel_LLVM = pprCLabel_NCG
-
-pprCLabel_ViaC :: Platform -> CLabel -> SDoc
-pprCLabel_ViaC = pprCLabel_other
-
-pprCLabel_NCG :: Platform -> CLabel -> SDoc
-pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
+ pdoc platform lbl = getPprStyle $ \case
+ PprCode CStyle -> pprCLabel platform CStyle lbl
+ PprCode AsmStyle -> pprCLabel platform AsmStyle lbl
+ _ -> pprCLabel platform CStyle lbl
+ -- default to CStyle
+
+pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+pprCLabel platform sty lbl =
let
-- some platform (e.g. Darwin) require a leading "_" for exported asm
-- symbols
maybe_underscore :: SDoc -> SDoc
- maybe_underscore doc =
- if platformLeadingUnderscore platform
- then pp_cSEP <> doc
- else doc
+ maybe_underscore doc = case sty of
+ AsmStyle | platformLeadingUnderscore platform -> pp_cSEP <> doc
+ _ -> doc
+
+ tempLabelPrefixOrUnderscore :: Platform -> SDoc
+ tempLabelPrefixOrUnderscore platform = case sty of
+ AsmStyle -> ptext (asmTempLabelPrefix platform)
+ CStyle -> char '_'
+
in case lbl of
- LocalBlockLabel u
- -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+ LocalBlockLabel u -> case sty of
+ AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+ CStyle -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
AsmTempLabel u
-> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
@@ -1252,11 +1254,11 @@ pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
-> ptext (asmTempLabelPrefix platform)
<> case l of AsmTempLabel u -> pprUniqueAlways u
LocalBlockLabel u -> pprUniqueAlways u
- _other -> pprCLabel_NCG platform l
+ _other -> pprCLabel platform sty l
<> ftext suf
DynamicLinkerLabel info lbl
- -> pprDynamicLinkerAsmLabel platform info lbl
+ -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl)
PicBaseLabel
-> text "1b"
@@ -1269,127 +1271,109 @@ pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
optional `_` (underscore) because this is how you mark non-temp symbols
on some platforms (Darwin)
-}
- maybe_underscore $ text "dsp_" <> pprCLabel_NCG platform lbl <> text "_dsp"
+ maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp"
StringLitLabel u
- -> pprUniqueAlways u <> ptext (sLit "_str")
+ -> maybe_underscore $ pprUniqueAlways u <> ptext (sLit "_str")
ForeignLabel fs (Just sz) _ _
- | asmStyle sty
+ | AsmStyle <- sty
, OSMinGW32 <- platformOS platform
-> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
-- (The C compiler does this itself).
maybe_underscore $ ftext fs <> char '@' <> int sz
- _ | asmStyle sty -> maybe_underscore $ pprCLabel_common platform lbl
- | otherwise -> pprCLabel_common platform lbl
-
-pprCLabel_other :: Platform -> CLabel -> SDoc
-pprCLabel_other platform lbl =
- case lbl of
- LocalBlockLabel u
- -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
-
- AsmTempLabel u
- | not (platformUnregisterised platform)
- -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
-
- lbl -> pprCLabel_common platform lbl
-
-
-pprCLabel_common :: Platform -> CLabel -> SDoc
-pprCLabel_common platform = \case
- (StringLitLabel u) -> pprUniqueAlways u <> text "_str"
- (SRTLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
- (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform
- <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
- -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
- -- until that gets resolved we'll just force them to start
- -- with a letter so the label will be legal assembly code.
-
- (CmmLabel _ _ str CmmCode) -> ftext str
- (CmmLabel _ _ str CmmData) -> ftext str
- (CmmLabel _ _ str CmmPrimCall) -> ftext str
-
- (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
-
- (RtsLabel (RtsApFast (NonDetFastString str))) -> ftext str <> text "_fast"
-
- (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->
- hcat [text "stg_sel_", text (show offset),
- ptext (if upd_reqd
- then (sLit "_upd_info")
- else (sLit "_noupd_info"))
- ]
-
- (RtsLabel (RtsSelectorEntry upd_reqd offset)) ->
- hcat [text "stg_sel_", text (show offset),
- ptext (if upd_reqd
- then (sLit "_upd_entry")
- else (sLit "_noupd_entry"))
- ]
-
- (RtsLabel (RtsApInfoTable upd_reqd arity)) ->
- hcat [text "stg_ap_", text (show arity),
- ptext (if upd_reqd
- then (sLit "_upd_info")
- else (sLit "_noupd_info"))
- ]
-
- (RtsLabel (RtsApEntry upd_reqd arity)) ->
- hcat [text "stg_ap_", text (show arity),
- ptext (if upd_reqd
- then (sLit "_upd_entry")
- else (sLit "_noupd_entry"))
- ]
-
- (CmmLabel _ _ fs CmmInfo) -> ftext fs <> text "_info"
- (CmmLabel _ _ fs CmmEntry) -> ftext fs <> text "_entry"
- (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info"
- (CmmLabel _ _ fs CmmRet) -> ftext fs <> text "_ret"
- (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure"
-
- (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop
- (RtsLabel (RtsSlowFastTickyCtr pat)) ->
- text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
-
- (ForeignLabel str _ _ _) -> ftext str
-
- (IdLabel name _cafs flavor) -> internalNamePrefix <> ppr name <> ppIdFlavor flavor
- where
- isRandomGenerated = not (isExternalName name)
- internalNamePrefix = getPprStyle $ \ sty ->
- if asmStyle sty && isRandomGenerated
- then ptext (asmTempLabelPrefix platform)
- else empty
-
- (CC_Label cc) -> ppr cc
- (CCS_Label ccs) -> ppr ccs
- (HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
-
- (AsmTempLabel {}) -> panic "pprCLabel_common AsmTempLabel"
- (AsmTempDerivedLabel {}) -> panic "pprCLabel_common AsmTempDerivedLabel"
- (DynamicLinkerLabel {}) -> panic "pprCLabel_common DynamicLinkerLabel"
- (PicBaseLabel {}) -> panic "pprCLabel_common PicBaseLabel"
- (DeadStripPreventer {}) -> panic "pprCLabel_common DeadStripPreventer"
+ ForeignLabel fs _ _ _
+ -> maybe_underscore $ ftext fs
+
+
+ IdLabel name _cafs flavor -> case sty of
+ AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor
+ where
+ isRandomGenerated = not (isExternalName name)
+ internalNamePrefix =
+ if isRandomGenerated
+ then ptext (asmTempLabelPrefix platform)
+ else empty
+ CStyle -> ppr name <> ppIdFlavor flavor
+
+ SRTLabel u
+ -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+
+ RtsLabel (RtsApFast (NonDetFastString str))
+ -> maybe_underscore $ ftext str <> text "_fast"
+
+ RtsLabel (RtsSelectorInfoTable upd_reqd offset)
+ -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
+ ]
+
+ RtsLabel (RtsSelectorEntry upd_reqd offset)
+ -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),
+ ptext (if upd_reqd
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
+ ]
+
+ RtsLabel (RtsApInfoTable upd_reqd arity)
+ -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),
+ ptext (if upd_reqd
+ then (sLit "_upd_info")
+ else (sLit "_noupd_info"))
+ ]
+
+ RtsLabel (RtsApEntry upd_reqd arity)
+ -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),
+ ptext (if upd_reqd
+ then (sLit "_upd_entry")
+ else (sLit "_noupd_entry"))
+ ]
+
+ RtsLabel (RtsPrimOp primop)
+ -> maybe_underscore $ text "stg_" <> ppr primop
+
+ RtsLabel (RtsSlowFastTickyCtr pat)
+ -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+
+ LargeBitmapLabel u
+ -> maybe_underscore $ tempLabelPrefixOrUnderscore platform
+ <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+ -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
+ -- until that gets resolved we'll just force them to start
+ -- with a letter so the label will be legal assembly code.
+
+ HpcTicksLabel mod
+ -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
+
+ CC_Label cc -> maybe_underscore $ ppr cc
+ CCS_Label ccs -> maybe_underscore $ ppr ccs
+
+ CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs
+ CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs
+ CmmLabel _ _ fs CmmPrimCall -> maybe_underscore $ ftext fs
+ CmmLabel _ _ fs CmmInfo -> maybe_underscore $ ftext fs <> text "_info"
+ CmmLabel _ _ fs CmmEntry -> maybe_underscore $ ftext fs <> text "_entry"
+ CmmLabel _ _ fs CmmRetInfo -> maybe_underscore $ ftext fs <> text "_info"
+ CmmLabel _ _ fs CmmRet -> maybe_underscore $ ftext fs <> text "_ret"
+ CmmLabel _ _ fs CmmClosure -> maybe_underscore $ ftext fs <> text "_closure"
-ppIdFlavor :: IdLabelInfo -> SDoc
-ppIdFlavor x = pp_cSEP <> text
- (case x of
- Closure -> "closure"
- InfoTable -> "info"
- LocalInfoTable -> "info"
- Entry -> "entry"
- LocalEntry -> "entry"
- Slow -> "slow"
- RednCounts -> "ct"
- ConEntry -> "con_entry"
- ConInfoTable -> "con_info"
- ClosureTable -> "closure_tbl"
- Bytes -> "bytes"
- BlockInfoTable -> "info"
- )
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <> case x of
+ Closure -> text "closure"
+ InfoTable -> text "info"
+ LocalInfoTable -> text "info"
+ Entry -> text "entry"
+ LocalEntry -> text "entry"
+ Slow -> text "slow"
+ RednCounts -> text "ct"
+ ConEntry -> text "con_entry"
+ ConInfoTable -> text "con_info"
+ ClosureTable -> text "closure_tbl"
+ Bytes -> text "bytes"
+ BlockInfoTable -> text "info"
pp_cSEP :: SDoc
pp_cSEP = char '_'
@@ -1402,14 +1386,6 @@ instance Outputable ForeignLabelSource where
ForeignLabelInThisPackage -> parens $ text "this package"
ForeignLabelInExternalPackage -> parens $ text "external package"
-tempLabelPrefixOrUnderscore :: Platform -> SDoc
-tempLabelPrefixOrUnderscore platform =
- getPprStyle $ \ sty ->
- if asmStyle sty then
- ptext (asmTempLabelPrefix platform)
- else
- char '_'
-
-- -----------------------------------------------------------------------------
-- Machine-dependent knowledge about labels.
@@ -1419,8 +1395,8 @@ asmTempLabelPrefix platform = case platformOS platform of
OSAIX -> sLit "__L" -- follow IBM XL C's convention
_ -> sLit ".L"
-pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
-pprDynamicLinkerAsmLabel platform dllInfo lbl =
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo ppLbl =
case platformOS platform of
OSDarwin
| platformArch platform == ArchX86_64 ->
@@ -1449,7 +1425,6 @@ pprDynamicLinkerAsmLabel platform dllInfo lbl =
_ -> panic "pprDynamicLinkerAsmLabel"
where
- ppLbl = pprCLabel_NCG platform lbl
elfLabel
| platformArch platform == ArchPPC
= case dllInfo of
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -803,7 +803,7 @@ makeImportsDoc dflags imports
doPpr lbl = (lbl, renderWithContext
(ncgAsmContext config)
- (pprCLabel_NCG platform lbl))
+ (pprCLabel platform AsmStyle lbl))
-- -----------------------------------------------------------------------------
-- Generate jump tables
@@ -1149,7 +1149,7 @@ cmmExprNative referenceKind expr = do
initNCGConfig :: DynFlags -> NCGConfig
initNCGConfig dflags = NCGConfig
{ ncgPlatform = targetPlatform dflags
- , ncgAsmContext = initSDocContext dflags (mkCodeStyle AsmStyle)
+ , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle)
, ncgProcAlignment = cmmProcAlignment dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, ncgPIC = positionIndependent dflags
=====================================
compiler/GHC/CmmToAsm/Dwarf/Types.hs
=====================================
@@ -164,9 +164,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
- $ withPprStyle (mkCodeStyle CStyle) -- force CStyle (foreign labels may be printed differently in AsmStyle)
- $ pprCLabel_NCG 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)
-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
=====================================
compiler/GHC/CmmToAsm/PIC.hs
=====================================
@@ -699,7 +699,7 @@ pprImportedSymbol config importedLbl = case (arch,os) of
_ -> panic "PIC.pprImportedSymbol: no match"
where
platform = ncgPlatform config
- ppr_lbl = pprCLabel_NCG platform
+ ppr_lbl = pprCLabel platform AsmStyle
arch = platformArch platform
os = platformOS platform
pic = ncgPIC config
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -91,7 +91,7 @@ pprTop platform = \case
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
- then mkFN_ else mkIF_) (pprCLabel_ViaC platform clbl) <+> lbrace,
+ then mkFN_ else mkIF_) (pprCLabel platform CStyle 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_ViaC platform lbl,
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,
text "[] = ", pprStringInCStyle str, semi
]
(CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
pprExternDecl platform lbl $$
hcat [
- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel_ViaC platform lbl,
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle 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_ViaC platform lbl, text "[]"
+ , space, pprCLabel platform CStyle lbl, text "[]"
-- See Note [StgWord alignment]
, pprAlignment (wordWidth platform)
, text "= {" ]
@@ -238,7 +238,7 @@ pprStmt platform stmt =
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
- pprCall platform (pprCLabel_ViaC platform lbl) cconv hresults hargs
+ pprCall platform (pprCLabel platform CStyle 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
@@ -247,7 +247,7 @@ pprStmt platform stmt =
| CmmNeverReturns <- ret ->
pprCall platform cast_fn cconv hresults hargs <> semi
| not (isMathFun lbl) ->
- pprForeignCall platform (pprCLabel_ViaC platform lbl) cconv hresults hargs
+ pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs
_ ->
pprCall platform cast_fn cconv hresults hargs <> semi
-- for a dynamic call, no declaration is necessary.
@@ -487,7 +487,7 @@ pprLit platform lit = case lit of
-> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
where
- pprCLabelAddr lbl = char '&' <> pprCLabel_ViaC platform lbl
+ pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl
pprLit1 :: Platform -> CmmLit -> SDoc
pprLit1 platform lit = case lit of
@@ -1047,7 +1047,7 @@ pprExternDecl platform lbl
| not (needsCDecl lbl) = empty
| Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
| otherwise =
- hcat [ visibility, label_type lbl , lparen, pprCLabel_ViaC platform lbl, text ");"
+ hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");"
-- occasionally useful to see label type
-- , text "/* ", pprDebugCLabel lbl, text " */"
]
@@ -1070,7 +1070,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_ViaC platform lbl
+ text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl
<> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
<> semi
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -435,7 +435,7 @@ renderLlvm sdoc = do
-- Write to output
dflags <- getDynFlags
out <- getEnv envOutput
- let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)
+ let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle)
liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
-- Dump, if requested
@@ -497,9 +497,9 @@ strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do
dflags <- getDynFlags
platform <- getPlatform
- let sdoc = pprCLabel_LLVM platform lbl
+ let sdoc = pprCLabel platform CStyle lbl
str = Outp.renderWithContext
- (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
+ (initSDocContext dflags (Outp.PprCode Outp.CStyle))
sdoc
return (fsLit str)
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1565,7 +1565,7 @@ genMachOp_slow opt op [x, y] = case op of
else do
-- Error. Continue anyway so we can debug the generated ll file.
dflags <- getDynFlags
- let style = mkCodeStyle CStyle
+ let style = PprCode CStyle
toString doc = renderWithContext (initSDocContext dflags style) doc
cmmToStr = (lines . toString . PprCmm.pprExpr platform)
statement $ Comment $ map fsLit $ cmmToStr x
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -240,7 +240,6 @@ import GHC.Unit.Home
import GHC.Unit.Types
import GHC.Unit.Parser
import GHC.Unit.Module
-import GHC.Driver.Ppr
import {-# SOURCE #-} GHC.Driver.Plugins
import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Builtin.Names ( mAIN )
@@ -1384,11 +1383,12 @@ jsonLogAction :: LogAction
jsonLogAction dflags reason severity srcSpan msg
= do
defaultLogActionHPutStrDoc dflags stdout
- (withPprStyle (mkCodeStyle CStyle) (doc $$ text ""))
+ (withPprStyle (PprCode CStyle) (doc $$ text ""))
where
+ str = renderWithContext (initSDocContext dflags defaultUserStyle) msg
doc = renderJSON $
JSObject [ ( "span", json srcSpan )
- , ( "doc" , JSString (showSDoc dflags msg) )
+ , ( "doc" , JSString str )
, ( "severity", json severity )
, ( "reason" , json reason )
]
@@ -1990,8 +1990,9 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
= runCmdLine (processArgs activeFlags args) dflags0
-- See Note [Handling errors when parsing commandline flags]
+ let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)
unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $
- map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs
+ map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs
-- check for disabled flags in safe haskell
let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
@@ -5094,7 +5095,6 @@ initSDocContext dflags style = SDC
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
, sdocPrintTypeAbbreviations = True
, sdocUnitIdForUser = ftext
- , sdocDynFlags = dflags
}
-- | Initialize the pretty-printing options using the default user style
=====================================
compiler/GHC/HsToCore/Coverage.hs
=====================================
@@ -1334,8 +1334,7 @@ hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)
]
where
platform = targetPlatform dflags
- bcknd = backend dflags
- tickboxes = pprCLabel bcknd platform (mkHpcTicksLabel $ this_mod)
+ tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)
module_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (moduleNameFS (moduleName this_mod)))
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -51,7 +51,7 @@ module GHC.Utils.Outputable (
-- * Converting 'SDoc' into strings and outputting it
printSDoc, printSDocLn,
bufLeftRenderSDoc,
- pprCode, mkCodeStyle,
+ pprCode,
showSDocOneLine,
renderWithContext,
@@ -68,14 +68,14 @@ module GHC.Utils.Outputable (
-- * Controlling the style in which output is printed
BindingSite(..),
- PprStyle(..), CodeStyle(..), PrintUnqualified(..),
+ PprStyle(..), LabelStyle(..), PrintUnqualified(..),
QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
reallyAlwaysQualify, reallyAlwaysQualifyNames,
alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
neverQualify, neverQualifyNames, neverQualifyModules,
alwaysQualifyPackages, neverQualifyPackages,
QualifyName(..), queryQual,
- sdocWithDynFlags, sdocOption,
+ sdocOption,
updSDocContext,
SDocContext (..), sdocWithContext, defaultSDocContext,
getPprStyle, withPprStyle, setStyleColoured,
@@ -92,7 +92,6 @@ module GHC.Utils.Outputable (
import GHC.Prelude
-import {-# SOURCE #-} GHC.Driver.Session ( DynFlags )
import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName )
import {-# SOURCE #-} GHC.Unit.Module.Name( ModuleName )
import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName )
@@ -150,11 +149,20 @@ data PprStyle
-- Does not assume tidied code: non-external names
-- are printed with uniques.
- | PprCode CodeStyle
- -- Print code; either C or assembler
+ | PprCode LabelStyle -- ^ Print code; either C or assembler
-data CodeStyle = CStyle -- The format of labels differs for C and assembler
- | AsmStyle
+-- | 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
@@ -375,8 +383,6 @@ data SDocContext = SDC
--
-- Note that we use `FastString` instead of `UnitId` to avoid boring
-- module inter-dependency issues.
-
- , sdocDynFlags :: DynFlags -- TODO: remove (see Note [The OutputableP class])
}
instance IsString SDoc where
@@ -424,7 +430,6 @@ defaultSDocContext = SDC
, sdocLinearTypes = False
, sdocPrintTypeAbbreviations = True
, sdocUnitIdForUser = ftext
- , sdocDynFlags = error "defaultSDocContext: DynFlags not available"
}
withPprStyle :: PprStyle -> SDoc -> SDoc
@@ -472,9 +477,6 @@ pprSetDepth depth doc = SDoc $ \ctx ->
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
-sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
-sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
-
sdocWithContext :: (SDocContext -> SDoc) -> SDoc
sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx
@@ -556,12 +558,9 @@ bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO ()
bufLeftRenderSDoc ctx bufHandle doc =
Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
-pprCode :: CodeStyle -> SDoc -> SDoc
+pprCode :: LabelStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
-mkCodeStyle :: CodeStyle -> PprStyle
-mkCodeStyle = PprCode
-
renderWithContext :: SDocContext -> SDoc -> String
renderWithContext ctx sdoc
= let s = Pretty.style{ Pretty.mode = PageMode,
@@ -966,9 +965,7 @@ instance Outputable Extension where
-- * selected backend: to display CLabel as C labels or Asm labels
--
-- In fact the whole compiler session state that is DynFlags was passed in
--- SDocContext and these values were retrieved from it. (At the time of writing,
--- a DynFlags field is still present into SDocContext but hopefully it shouldn't
--- last long).
+-- SDocContext and these values were retrieved from it.
--
-- The Outputable class makes SDoc creation easy for many values by providing
-- the ppr method:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7385f7077c6258c2a76ae51b4ea80f6fa9c7015...a997fa01d907fc1992dc8c3ebc73f98e7a1486f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7385f7077c6258c2a76ae51b4ea80f6fa9c7015...a997fa01d907fc1992dc8c3ebc73f98e7a1486f7
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/20200923/b523d874/attachment-0001.html>
More information about the ghc-commits
mailing list