[Git][ghc/ghc][master] Don't rely on CLabel's Outputable instance in CmmToC
Marge Bot
gitlab at gitlab.haskell.org
Fri Sep 4 20:24:28 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
1d6d6488 by Sylvain Henry at 2020-09-04T16:24:20-04:00
Don't rely on CLabel's Outputable instance in CmmToC
This is in preparation of the removal of sdocWithDynFlags (#10143),
hence of the refactoring of CLabel's Outputable instance.
- - - - -
2 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToC.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -108,7 +108,7 @@ module GHC.Cmm.CLabel (
-- * Conversions
toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
- pprCLabel, pprCLabel_LLVM, pprCLabel_NCG,
+ pprCLabel, pprCLabel_LLVM, pprCLabel_NCG, pprCLabel_ViaC,
isInfoTableLabel,
isConInfoTableLabel,
isIdLabel, isTickyLabel
@@ -1218,11 +1218,15 @@ 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 ->
let
@@ -1348,7 +1352,13 @@ pprCLabel_common platform = \case
(ForeignLabel str _ _ _) -> ftext str
- (IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor
+ (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
@@ -1389,15 +1399,6 @@ instance Outputable ForeignLabelSource where
ForeignLabelInThisPackage -> parens $ text "this package"
ForeignLabelInExternalPackage -> parens $ text "external package"
-internalNamePrefix :: Platform -> Name -> SDoc
-internalNamePrefix platform name = getPprStyle $ \ sty ->
- if asmStyle sty && isRandomGenerated then
- ptext (asmTempLabelPrefix platform)
- else
- empty
- where
- isRandomGenerated = not $ isExternalName name
-
tempLabelPrefixOrUnderscore :: Platform -> SDoc
tempLabelPrefixOrUnderscore platform =
getPprStyle $ \ sty ->
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -91,7 +91,7 @@ pprTop platform = \case
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
- then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
+ then mkFN_ else mkIF_) (pprCLabel_ViaC 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 ", ppr lbl,
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel_ViaC platform lbl,
text "[] = ", pprStringInCStyle str, semi
]
(CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
pprExternDecl platform lbl $$
hcat [
- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel_ViaC 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, ppr lbl, text "[]"
+ , space, pprCLabel_ViaC platform 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 (ppr lbl) cconv hresults hargs
+ pprCall platform (pprCLabel_ViaC 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
@@ -247,7 +247,7 @@ pprStmt platform stmt =
| CmmNeverReturns <- ret ->
pprCall platform cast_fn cconv hresults hargs <> semi
| not (isMathFun lbl) ->
- pprForeignCall platform (ppr lbl) cconv hresults hargs
+ pprForeignCall platform (pprCLabel_ViaC platform 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 '&' <> ppr lbl
+ pprCLabelAddr lbl = char '&' <> pprCLabel_ViaC platform 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, ppr lbl, text ");"
+ hcat [ visibility, label_type lbl , lparen, pprCLabel_ViaC platform 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 " <> ppr lbl
+ text "extern __attribute__((stdcall)) void " <> pprCLabel_ViaC platform lbl
<> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
<> semi
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d6d648866da9e7754859c48235f8009b8c130fd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d6d648866da9e7754859c48235f8009b8c130fd
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/20200904/6103de2c/attachment-0001.html>
More information about the ghc-commits
mailing list