[Git][ghc/ghc][master] 2 commits: Refactor CLabel pretty-printing
Marge Bot
gitlab at gitlab.haskell.org
Sat Aug 1 08:22:37 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
56a7c193 by Sylvain Henry at 2020-07-31T19:32:09+02:00
Refactor CLabel pretty-printing
Pretty-printing CLabel relies on sdocWithDynFlags that we want to remove
(#10143, #17957). It uses it to query the backend and the platform.
This patch exposes Clabel ppr functions specialised for each backend so
that backend code can directly use them.
- - - - -
3b15dc3c by Sylvain Henry at 2020-07-31T19:32:09+02:00
DynFlags: don't use sdocWithDynFlags in GHC.CmmToAsm.Dwarf.Types
- - - - -
17 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/ProcPoint.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Dwarf/Types.hs
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/StgToCmm/Layout.hs
- rts/Hpc.c
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -108,7 +108,7 @@ module GHC.Cmm.CLabel (
-- * Conversions
toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
- pprCLabel,
+ pprCLabel, pprCLabel_LLVM, pprCLabel_NCG,
isInfoTableLabel,
isConInfoTableLabel,
isIdLabel, isTickyLabel
@@ -242,7 +242,7 @@ data CLabel
-- | These labels are generated and used inside the NCG only.
-- They are special variants of a label used for dynamic linking
- -- see module PositionIndependentCode for details.
+ -- see module "GHC.CmmToAsm.PIC" for details.
| DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
-- | This label is generated and used inside the NCG only.
@@ -398,23 +398,24 @@ data ForeignLabelSource
-- We can't make a Show instance for CLabel because lots of its components don't have instances.
-- The regular Outputable instance only shows the label name, and not its other info.
--
-pprDebugCLabel :: CLabel -> SDoc
-pprDebugCLabel lbl
+pprDebugCLabel :: Platform -> CLabel -> SDoc
+pprDebugCLabel platform lbl
= case lbl of
- IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"
- <> whenPprDebug (text ":" <> text (show info)))
+ IdLabel _ _ info-> pprCLabel_other platform lbl
+ <> (parens $ text "IdLabel"
+ <> whenPprDebug (text ":" <> text (show info)))
CmmLabel pkg _ext _name _info
- -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+ -> pprCLabel_other platform lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
- RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel")
+ RtsLabel{} -> pprCLabel_other platform lbl <> (parens $ text "RtsLabel")
ForeignLabel _name mSuffix src funOrData
- -> ppr lbl <> (parens $ text "ForeignLabel"
- <+> ppr mSuffix
- <+> ppr src
- <+> ppr funOrData)
+ -> pprCLabel_other platform lbl <> (parens $ text "ForeignLabel"
+ <+> ppr mSuffix
+ <+> ppr src
+ <+> ppr funOrData)
- _ -> ppr lbl <> (parens $ text "other CLabel")
+ _ -> pprCLabel_other platform lbl <> (parens $ text "other CLabel")
data IdLabelInfo
@@ -753,34 +754,37 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
-- -----------------------------------------------------------------------------
-- Convert between different kinds of label
-toClosureLbl :: CLabel -> CLabel
-toClosureLbl (IdLabel n c _) = IdLabel n c Closure
-toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure
-toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
-
-toSlowEntryLbl :: CLabel -> CLabel
-toSlowEntryLbl (IdLabel n _ BlockInfoTable)
- = pprPanic "toSlowEntryLbl" (ppr n)
-toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow
-toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)
-
-toEntryLbl :: CLabel -> CLabel
-toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry
-toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry
-toEntryLbl (IdLabel n _ BlockInfoTable) = mkLocalBlockLabel (nameUnique n)
- -- See Note [Proc-point local block entry-point].
-toEntryLbl (IdLabel n c _) = IdLabel n c Entry
-toEntryLbl (CmmLabel m ext str CmmInfo) = CmmLabel m ext str CmmEntry
-toEntryLbl (CmmLabel m ext str CmmRetInfo) = CmmLabel m ext str CmmRet
-toEntryLbl l = pprPanic "toEntryLbl" (ppr l)
-
-toInfoLbl :: CLabel -> CLabel
-toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable
-toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable
-toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable
-toInfoLbl (CmmLabel m ext str CmmEntry)= CmmLabel m ext str CmmInfo
-toInfoLbl (CmmLabel m ext str CmmRet) = CmmLabel m ext str CmmRetInfo
-toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)
+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)
+
+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)
+
+toEntryLbl :: Platform -> CLabel -> CLabel
+toEntryLbl platform lbl = case lbl of
+ IdLabel n c LocalInfoTable -> IdLabel n c LocalEntry
+ IdLabel n c ConInfoTable -> IdLabel n c ConEntry
+ IdLabel n _ BlockInfoTable -> mkLocalBlockLabel (nameUnique n)
+ -- See Note [Proc-point local block entry-point].
+ 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)
+
+toInfoLbl :: Platform -> CLabel -> CLabel
+toInfoLbl platform lbl = case lbl of
+ IdLabel n c LocalEntry -> IdLabel n c LocalInfoTable
+ IdLabel n c ConEntry -> IdLabel n c ConInfoTable
+ 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)
hasHaskellName :: CLabel -> Maybe Name
hasHaskellName (IdLabel n _ _) = Just n
@@ -1208,34 +1212,50 @@ and are not externally visible.
-}
instance Outputable CLabel where
- ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c
+ ppr lbl = sdocWithDynFlags (\dflags -> pprCLabel (backend dflags) (targetPlatform dflags) lbl)
+
+pprCLabel :: Backend -> Platform -> CLabel -> SDoc
+pprCLabel bcknd platform lbl =
+ case bcknd of
+ NCG -> pprCLabel_NCG platform lbl
+ LLVM -> pprCLabel_LLVM platform lbl
+ _ -> pprCLabel_other platform lbl
+
+pprCLabel_LLVM :: Platform -> CLabel -> SDoc
+pprCLabel_LLVM = pprCLabel_NCG
+
+pprCLabel_NCG :: Platform -> CLabel -> SDoc
+pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
+ 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
-pprCLabel :: DynFlags -> CLabel -> SDoc
-pprCLabel dflags = \case
- (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
+ in case lbl of
+ LocalBlockLabel u
+ -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
- (AsmTempLabel u)
- | not (platformUnregisterised platform)
+ AsmTempLabel u
-> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
- (AsmTempDerivedLabel l suf)
- | useNCG
+ AsmTempDerivedLabel l suf
-> ptext (asmTempLabelPrefix platform)
<> case l of AsmTempLabel u -> pprUniqueAlways u
LocalBlockLabel u -> pprUniqueAlways u
- _other -> pprCLabel dflags l
+ _other -> pprCLabel_NCG platform l
<> ftext suf
- (DynamicLinkerLabel info lbl)
- | useNCG
+ DynamicLinkerLabel info lbl
-> pprDynamicLinkerAsmLabel platform info lbl
PicBaseLabel
- | useNCG
-> text "1b"
- (DeadStripPreventer lbl)
- | useNCG
+ DeadStripPreventer lbl
->
{-
`lbl` can be temp one but we need to ensure that dsp label will stay
@@ -1243,36 +1263,36 @@ pprCLabel dflags = \case
optional `_` (underscore) because this is how you mark non-temp symbols
on some platforms (Darwin)
-}
- maybe_underscore $ text "dsp_" <> pprCLabel dflags lbl <> text "_dsp"
+ maybe_underscore $ text "dsp_" <> pprCLabel_NCG platform lbl <> text "_dsp"
- (StringLitLabel u)
- | useNCG
+ StringLitLabel u
-> pprUniqueAlways u <> ptext (sLit "_str")
- lbl -> getPprStyle $ \sty ->
- if useNCG && asmStyle sty
- then maybe_underscore $ pprAsmCLbl lbl
- else pprCLbl platform lbl
+ ForeignLabel fs (Just sz) _ _
+ | 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
- where
- platform = targetPlatform dflags
- useNCG = backend dflags == NCG
+ _ | asmStyle sty -> maybe_underscore $ pprCLabel_common platform lbl
+ | otherwise -> pprCLabel_common platform lbl
- maybe_underscore :: SDoc -> SDoc
- maybe_underscore doc =
- if platformLeadingUnderscore platform
- then pp_cSEP <> doc
- else doc
+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
- pprAsmCLbl (ForeignLabel fs (Just sz) _ _)
- | platformOS platform == OSMinGW32
- -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
- -- (The C compiler does this itself).
- = ftext fs <> char '@' <> int sz
- pprAsmCLbl lbl = pprCLbl platform lbl
-pprCLbl :: Platform -> CLabel -> SDoc
-pprCLbl platform = \case
+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
@@ -1335,11 +1355,11 @@ pprCLbl platform = \case
(CCS_Label ccs) -> ppr ccs
(HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
- (AsmTempLabel {}) -> panic "pprCLbl AsmTempLabel"
- (AsmTempDerivedLabel {}) -> panic "pprCLbl AsmTempDerivedLabel"
- (DynamicLinkerLabel {}) -> panic "pprCLbl DynamicLinkerLabel"
- (PicBaseLabel {}) -> panic "pprCLbl PicBaseLabel"
- (DeadStripPreventer {}) -> panic "pprCLbl DeadStripPreventer"
+ (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"
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <> text
@@ -1402,60 +1422,60 @@ pprDynamicLinkerAsmLabel platform dllInfo lbl =
OSDarwin
| platformArch platform == ArchX86_64 ->
case dllInfo of
- CodeStub -> char 'L' <> ppr lbl <> text "$stub"
- SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
- GotSymbolPtr -> ppr lbl <> text "@GOTPCREL"
- GotSymbolOffset -> ppr lbl
+ CodeStub -> char 'L' <> ppLbl <> text "$stub"
+ SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"
+ GotSymbolPtr -> ppLbl <> text "@GOTPCREL"
+ GotSymbolOffset -> ppLbl
| otherwise ->
case dllInfo of
- CodeStub -> char 'L' <> ppr lbl <> text "$stub"
- SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+ CodeStub -> char 'L' <> ppLbl <> text "$stub"
+ SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"
_ -> panic "pprDynamicLinkerAsmLabel"
OSAIX ->
case dllInfo of
- SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention
+ SymbolPtr -> text "LC.." <> ppLbl -- GCC's naming convention
_ -> panic "pprDynamicLinkerAsmLabel"
_ | osElfTarget (platformOS platform) -> elfLabel
OSMinGW32 ->
case dllInfo of
- SymbolPtr -> text "__imp_" <> ppr lbl
+ SymbolPtr -> text "__imp_" <> ppLbl
_ -> panic "pprDynamicLinkerAsmLabel"
_ -> panic "pprDynamicLinkerAsmLabel"
where
+ ppLbl = pprCLabel_NCG platform lbl
elfLabel
| platformArch platform == ArchPPC
= case dllInfo of
CodeStub -> -- See Note [.LCTOC1 in PPC PIC code]
- ppr lbl <> text "+32768 at plt"
- SymbolPtr -> text ".LC_" <> ppr lbl
+ ppLbl <> text "+32768 at plt"
+ SymbolPtr -> text ".LC_" <> ppLbl
_ -> panic "pprDynamicLinkerAsmLabel"
| platformArch platform == ArchX86_64
= case dllInfo of
- CodeStub -> ppr lbl <> text "@plt"
- GotSymbolPtr -> ppr lbl <> text "@gotpcrel"
- GotSymbolOffset -> ppr lbl
- SymbolPtr -> text ".LC_" <> ppr lbl
+ CodeStub -> ppLbl <> text "@plt"
+ GotSymbolPtr -> ppLbl <> text "@gotpcrel"
+ GotSymbolOffset -> ppLbl
+ SymbolPtr -> text ".LC_" <> ppLbl
| platformArch platform == ArchPPC_64 ELF_V1
|| platformArch platform == ArchPPC_64 ELF_V2
= case dllInfo of
- GotSymbolPtr -> text ".LC_" <> ppr lbl
- <> text "@toc"
- GotSymbolOffset -> ppr lbl
- SymbolPtr -> text ".LC_" <> ppr lbl
+ GotSymbolPtr -> text ".LC_" <> ppLbl <> text "@toc"
+ GotSymbolOffset -> ppLbl
+ SymbolPtr -> text ".LC_" <> ppLbl
_ -> panic "pprDynamicLinkerAsmLabel"
| otherwise
= case dllInfo of
- CodeStub -> ppr lbl <> text "@plt"
- SymbolPtr -> text ".LC_" <> ppr lbl
- GotSymbolPtr -> ppr lbl <> text "@got"
- GotSymbolOffset -> ppr lbl <> text "@gotoff"
+ CodeStub -> ppLbl <> text "@plt"
+ SymbolPtr -> text ".LC_" <> ppLbl
+ GotSymbolPtr -> ppLbl <> text "@got"
+ GotSymbolOffset -> ppLbl <> text "@gotoff"
-- Figure out whether `symbol` may serve as an alias
-- to `target` within one compilation unit.
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -253,7 +253,7 @@ mkInfoTableContents dflags
++ [ liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
where
- slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
+ slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
srt_lit = case srt_label of
[] -> mkIntCLit platform 0
(lit:_rest) -> ASSERT( null _rest ) lit
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -459,8 +459,8 @@ newtype CAFLabel = CAFLabel CLabel
type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet
-mkCAFLabel :: CLabel -> CAFLabel
-mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+mkCAFLabel :: Platform -> CLabel -> CAFLabel
+mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)
-- This is a label that we can put in an SRT. It *must* be a closure label,
-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
@@ -470,10 +470,10 @@ newtype SRTEntry = SRTEntry CLabel
-- ---------------------------------------------------------------------
-- CAF analysis
-addCafLabel :: CLabel -> CAFSet -> CAFSet
-addCafLabel l s
+addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
+addCafLabel platform l s
| Just _ <- hasHaskellName l
- , let caf_label = mkCAFLabel l
+ , let caf_label = mkCAFLabel platform l
-- For imported Ids hasCAF will have accurate CafInfo
-- Locals are initialized as CAFFY. We turn labels with empty SRTs into
-- non-CAFFYs in doSRTs
@@ -483,21 +483,20 @@ addCafLabel l s
= s
cafAnalData
- :: CmmStatics
+ :: Platform
+ -> CmmStatics
-> CAFSet
-
-cafAnalData (CmmStaticsRaw _lbl _data) =
- Set.empty
-
-cafAnalData (CmmStatics _lbl _itbl _ccs payload) =
- foldl' analyzeStatic Set.empty payload
- where
- analyzeStatic s lit =
- case lit of
- CmmLabel c -> addCafLabel c s
- CmmLabelOff c _ -> addCafLabel c s
- CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s
- _ -> s
+cafAnalData platform st = case st of
+ CmmStaticsRaw _lbl _data -> Set.empty
+ CmmStatics _lbl _itbl _ccs payload ->
+ foldl' analyzeStatic Set.empty payload
+ where
+ analyzeStatic s lit =
+ case lit of
+ CmmLabel c -> addCafLabel platform c s
+ CmmLabelOff c _ -> addCafLabel platform c s
+ CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s
+ _ -> s
-- |
-- For each code block:
@@ -507,16 +506,17 @@ cafAnalData (CmmStatics _lbl _itbl _ccs payload) =
-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
--
cafAnal
- :: LabelSet -- The blocks representing continuations, ie. those
+ :: Platform
+ -> LabelSet -- The blocks representing continuations, ie. those
-- that will get RET info tables. These labels will
-- get their own SRTs, so we don't aggregate CAFs from
-- references to these labels, we just use the label.
-> CLabel -- The top label of the proc
-> CmmGraph
-> CAFEnv
-cafAnal contLbls topLbl cmmGraph =
+cafAnal platform contLbls topLbl cmmGraph =
analyzeCmmBwd cafLattice
- (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+ (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
cafLattice :: DataflowLattice CAFSet
@@ -527,8 +527,8 @@ cafLattice = DataflowLattice Set.empty add
in changedIf (Set.size new' > Set.size old) new'
-cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
-cafTransfers contLbls entry topLbl
+cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers platform contLbls entry topLbl
block@(BlockCC eNode middle xNode) fBase =
let joined :: CAFSet
joined = cafsInNode xNode $! live'
@@ -546,11 +546,11 @@ cafTransfers contLbls entry topLbl
successorFact s
-- If this is a loop back to the entry, we can refer to the
-- entry label.
- | s == entry = Just (addCafLabel topLbl Set.empty)
+ | s == entry = Just (addCafLabel platform topLbl Set.empty)
-- If this is a continuation, we want to refer to the
-- SRT for the continuation's info table
| s `setMember` contLbls
- = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
+ = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))
-- Otherwise, takes the CAF references from the destination
| otherwise
= lookupFact s fBase
@@ -562,11 +562,11 @@ cafTransfers contLbls entry topLbl
addCafExpr expr !set =
case expr of
CmmLit (CmmLabel c) ->
- addCafLabel c set
+ addCafLabel platform c set
CmmLit (CmmLabelOff c _) ->
- addCafLabel c set
+ addCafLabel platform c set
CmmLit (CmmLabelDiffOff c1 c2 _ _) ->
- addCafLabel c1 $! addCafLabel c2 set
+ addCafLabel platform c1 $! addCafLabel platform c2 set
_ ->
set
in
@@ -649,35 +649,34 @@ getBlockLabels = mapMaybe getBlockLabel
-- where the label is
-- - the info label for a continuation or dynamic closure
-- - the closure label for a top-level function (not a CAF)
-getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)]
-getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) =
- []
-getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) =
- [ (DeclLabel lbl, mkCAFLabel lbl) ]
-getLabelledBlocks (CmmProc top_info _ _ _) =
- [ (BlockLabel blockId, caf_lbl)
- | (blockId, info) <- mapToList (info_tbls top_info)
- , let rep = cit_rep info
- , not (isStaticRep rep) || not (isThunkRep rep)
- , let !caf_lbl = mkCAFLabel (cit_lbl info)
- ]
+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
+getLabelledBlocks platform decl = case decl of
+ CmmData _ (CmmStaticsRaw _ _) -> []
+ CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]
+ CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl)
+ | (blockId, info) <- mapToList (info_tbls top_info)
+ , let rep = cit_rep info
+ , not (isStaticRep rep) || not (isThunkRep rep)
+ , let !caf_lbl = mkCAFLabel platform (cit_lbl info)
+ ]
-- | Put the labelled blocks that we will be annotating with SRTs into
-- dependency order. This is so that we can process them one at a
-- time, resolving references to earlier blocks to point to their
-- SRTs. CAFs themselves are not included here; see getCAFs below.
depAnalSRTs
- :: CAFEnv
+ :: Platform
+ -> CAFEnv
-> Map CLabel CAFSet -- CAFEnv for statics
-> [CmmDecl]
-> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
-depAnalSRTs cafEnv cafEnv_static decls =
+depAnalSRTs platform cafEnv cafEnv_static decls =
srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$
text "nodes:" <+> ppr (map node_payload nodes) $$
text "graph:" <+> ppr graph) graph
where
labelledBlocks :: [(SomeLabel, CAFLabel)]
- labelledBlocks = concatMap getLabelledBlocks decls
+ labelledBlocks = concatMap (getLabelledBlocks platform) decls
labelToBlock :: Map CAFLabel SomeLabel
labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks
@@ -701,9 +700,9 @@ depAnalSRTs cafEnv cafEnv_static decls =
-- SRT, since the point of SRTs is to keep CAFs alive.
-- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
-- instead we generate their SRTs after everything else.
-getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
-getCAFs cafEnv decls =
- [ (g_entry g, mkCAFLabel topLbl, cafs)
+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs platform cafEnv decls =
+ [ (g_entry g, mkCAFLabel platform topLbl, cafs)
| CmmProc top_info topLbl _ g <- decls
, Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
, let rep = cit_rep info
@@ -747,11 +746,11 @@ srtMapNonCAFs srtMap =
get_name (_l, Just _srt_entry) = Nothing
-- | resolve a CAFLabel to its SRTEntry using the SRTMap
-resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
-resolveCAF srtMap lbl@(CAFLabel l) =
+resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF platform srtMap lbl@(CAFLabel l) =
srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret
where
- ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
+ ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap
-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
-- declarations to the ModuleSRTInfo.
@@ -791,6 +790,8 @@ doSRTs dflags moduleSRTInfo procs data_ = do
decls = map snd data_ ++ concat procss
staticFuns = mapFromList (getStaticFuns decls)
+ platform = targetPlatform dflags
+
-- Put the decls in dependency order. Why? So that we can implement
-- [Inline] and [Filter]. If we need to refer to an SRT that has
-- a single entry, we use the entry itself, which means that we
@@ -799,10 +800,10 @@ doSRTs dflags moduleSRTInfo procs data_ = do
-- them.
let
sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
- sccs = {-# SCC depAnalSRTs #-} depAnalSRTs cafEnv static_data_env decls
+ sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls
cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
- cafsWithSRTs = getCAFs cafEnv decls
+ cafsWithSRTs = getCAFs platform cafEnv decls
srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$
text "procs:" <+> ppr procs $$
@@ -853,7 +854,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do
-- be CAFFY.
-- See Note [Ticky labels in SRT analysis] above for
-- why we exclude ticky labels here.
- Map.insert (mkCAFLabel lbl) Nothing srtMap
+ Map.insert (mkCAFLabel platform lbl) Nothing srtMap
| otherwise ->
-- Not an IdLabel, ignore
srtMap
@@ -933,6 +934,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
let
config = initConfig dflags
profile = targetProfile dflags
+ platform = profilePlatform profile
srtMap = moduleSRTMap topSRT
blockids = getBlockLabels lbls
@@ -951,7 +953,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
-- Resolve references to their SRT entries
resolved :: [SRTEntry]
- resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)
+ resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec)
-- The set of all SRTEntries in SRTs that we refer to from here.
allBelow =
@@ -1016,7 +1018,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
-- We're going to build an SRT for this group, which should include function
-- references in the group. See Note [recursive SRTs].
let allBelow_funs =
- Set.fromList (map (SRTEntry . toClosureLbl) otherFunLabels)
+ Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)
let filtered = filtered0 `Set.union` allBelow_funs
srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$
text "allBelow_funs:" <+> ppr allBelow_funs)
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -46,7 +46,7 @@ cmmPipeline
cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
- tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
+ tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog
let (procs, data_) = partitionEithers tops
(srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_
@@ -59,9 +59,9 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline")
dflags = hsc_dflags hsc_env
-cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
-cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p))
-cpsTop hsc_env proc =
+cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
+cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))
+cpsTop dflags proc =
do
----------- Control-flow optimisations ----------------------------------
@@ -118,7 +118,7 @@ cpsTop hsc_env proc =
Opt_D_dump_cmm_sink "Sink assignments"
------------- CAF analysis ----------------------------------------------
- let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
+ let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)
g <- if splitting_proc_points
@@ -153,8 +153,7 @@ cpsTop hsc_env proc =
return (Left (cafEnv, g))
- where dflags = hsc_dflags hsc_env
- platform = targetPlatform dflags
+ where platform = targetPlatform dflags
dump = dumpGraph dflags
dumps flag name
=====================================
compiler/GHC/Cmm/ProcPoint.hs
=====================================
@@ -319,7 +319,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
tablesNextToCode = platformTablesNextToCode platform
jump_label (Just info_lbl) _
| tablesNextToCode = info_lbl
- | otherwise = toEntryLbl info_lbl
+ | otherwise = toEntryLbl platform info_lbl
jump_label Nothing block_lbl = block_lbl
add_if_pp id rst = case mapLookup id procLabels of
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -891,7 +891,7 @@ makeImportsDoc dflags imports
| needImportedSymbols config
= vcat $
(pprGotDeclaration config :) $
- map ( pprImportedSymbol dflags config . fst . head) $
+ map ( pprImportedSymbol config . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
@@ -901,7 +901,7 @@ makeImportsDoc dflags imports
doPpr lbl = (lbl, renderWithStyle
(initSDocContext dflags astyle)
- (pprCLabel dflags lbl))
+ (pprCLabel_NCG platform lbl))
astyle = mkCodeStyle AsmStyle
-- -----------------------------------------------------------------------------
=====================================
compiler/GHC/CmmToAsm/Dwarf/Types.hs
=====================================
@@ -156,6 +156,13 @@ pprDwarfInfo platform haveSrc d
pprDwarfInfoClose
noChildren = pprDwarfInfoOpen 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
+
-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
-- has to be kept in synch.
@@ -172,12 +179,11 @@ pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowL
$$ if haveSrc
then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)
else empty
-pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label
- parent) = sdocWithDynFlags $ \df ->
+pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
- $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
+ $$ pprLabelString platform label
$$ pprFlag (externallyVisibleCLabel label)
$$ pprWord platform (ppr label)
$$ pprWord platform (ppr $ mkAsmTempEndLabel label)
@@ -189,14 +195,14 @@ pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label
Just _ -> DwAbbrSubprogramWithParent
parentValue = maybe empty pprParentDie parent
pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)
-pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
+pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
- $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
-pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
+ $$ pprLabelString platform label
+pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
- $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
+ $$ pprLabelString platform label
$$ pprWord platform (ppr marker)
$$ pprWord platform (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
=====================================
compiler/GHC/CmmToAsm/PIC.hs
=====================================
@@ -2,7 +2,7 @@
This module handles generation of position independent code and
dynamic-linking related issues for the native code generator.
- This depends both the architecture and OS, so we define it here
+ This depends on both the architecture and OS, so we define it here
instead of in one of the architecture specific modules.
Things outside this module which are related to this:
@@ -62,20 +62,13 @@ import GHC.CmmToAsm.Config
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm
-import GHC.Cmm.CLabel ( CLabel, ForeignLabelSource(..), pprCLabel,
- mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
- dynamicLinkerLabelInfo, mkPicBaseLabel,
- labelDynamic, externallyVisibleCLabel )
-
-import GHC.Cmm.CLabel ( mkForeignLabel )
-
+import GHC.Cmm.CLabel
import GHC.Types.Basic
import GHC.Unit.Module
import GHC.Utils.Outputable
-import GHC.Driver.Session
import GHC.Data.FastString
@@ -573,21 +566,21 @@ pprGotDeclaration config = case (arch,os) of
-- and one for non-PIC.
--
-pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc
-pprImportedSymbol dflags config importedLbl = case (arch,os) of
+pprImportedSymbol :: NCGConfig -> CLabel -> SDoc
+pprImportedSymbol config importedLbl = case (arch,os) of
(ArchX86, OSDarwin)
| Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-> if not pic
then
vcat [
text ".symbol_stub",
- text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
- text "\tjmp *L" <> pprCLabel dflags lbl
+ text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),
+ text "\t.indirect_symbol" <+> ppr_lbl lbl,
+ text "\tjmp *L" <> ppr_lbl lbl
<> text "$lazy_ptr",
- text "L" <> pprCLabel dflags lbl
+ text "L" <> ppr_lbl lbl
<> text "$stub_binder:",
- text "\tpushl $L" <> pprCLabel dflags lbl
+ text "\tpushl $L" <> ppr_lbl lbl
<> text "$lazy_ptr",
text "\tjmp dyld_stub_binding_helper"
]
@@ -595,16 +588,16 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
vcat [
text ".section __TEXT,__picsymbolstub2,"
<> text "symbol_stubs,pure_instructions,25",
- text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
+ text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),
+ text "\t.indirect_symbol" <+> ppr_lbl lbl,
text "\tcall ___i686.get_pc_thunk.ax",
text "1:",
- text "\tmovl L" <> pprCLabel dflags lbl
+ text "\tmovl L" <> ppr_lbl lbl
<> text "$lazy_ptr-1b(%eax),%edx",
text "\tjmp *%edx",
- text "L" <> pprCLabel dflags lbl
+ text "L" <> ppr_lbl lbl
<> text "$stub_binder:",
- text "\tlea L" <> pprCLabel dflags lbl
+ text "\tlea L" <> ppr_lbl lbl
<> text "$lazy_ptr-1b(%eax),%eax",
text "\tpushl %eax",
text "\tjmp dyld_stub_binding_helper"
@@ -612,16 +605,16 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
$+$ vcat [ text ".section __DATA, __la_sym_ptr"
<> (if pic then int 2 else int 3)
<> text ",lazy_symbol_pointers",
- text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),
- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
- text "\t.long L" <> pprCLabel dflags lbl
+ text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"),
+ text "\t.indirect_symbol" <+> ppr_lbl lbl,
+ text "\t.long L" <> ppr_lbl lbl
<> text "$stub_binder"]
| Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
-> vcat [
text ".non_lazy_symbol_pointer",
- char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",
- text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
+ char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",
+ text "\t.indirect_symbol" <+> ppr_lbl lbl,
text "\t.long\t0"]
| otherwise
@@ -644,8 +637,8 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
(_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
-> vcat [
- text "LC.." <> pprCLabel dflags lbl <> char ':',
- text "\t.long" <+> pprCLabel dflags lbl ]
+ text "LC.." <> ppr_lbl lbl <> char ':',
+ text "\t.long" <+> ppr_lbl lbl ]
_ -> empty
-- ELF / Linux
@@ -682,8 +675,8 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
-> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
-> vcat [
- text ".LC_" <> pprCLabel dflags lbl <> char ':',
- text "\t.quad" <+> pprCLabel dflags lbl ]
+ text ".LC_" <> ppr_lbl lbl <> char ':',
+ text "\t.quad" <+> ppr_lbl lbl ]
_ -> empty
_ | osElfTarget os
@@ -696,8 +689,8 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
in vcat [
text ".section \".got2\", \"aw\"",
- text ".LC_" <> pprCLabel dflags lbl <> char ':',
- ptext symbolSize <+> pprCLabel dflags lbl ]
+ text ".LC_" <> ppr_lbl lbl <> char ':',
+ ptext symbolSize <+> ppr_lbl lbl ]
-- PLT code stubs are generated automatically by the dynamic linker.
_ -> empty
@@ -705,8 +698,9 @@ pprImportedSymbol dflags config importedLbl = case (arch,os) of
_ -> panic "PIC.pprImportedSymbol: no match"
where
platform = ncgPlatform config
- arch = platformArch platform
- os = platformOS platform
+ ppr_lbl = pprCLabel_NCG platform
+ arch = platformArch platform
+ os = platformOS platform
pic = ncgPIC config
--------------------------------------------------------------------------------
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -496,7 +496,8 @@ ghcInternalFunctions = do
strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do
dflags <- getDynFlags
- let sdoc = pprCLabel dflags lbl
+ platform <- getPlatform
+ let sdoc = pprCLabel_LLVM platform lbl
str = Outp.renderWithStyle
(initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
sdoc
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -140,7 +140,7 @@ deSugar hsc_env
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
; let hpc_init
- | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
+ | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info
| otherwise = empty
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
=====================================
compiler/GHC/HsToCore/Coverage.hs
=====================================
@@ -1315,9 +1315,9 @@ static void hpc_init_Main(void)
hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
-}
-hpcInitCode :: Module -> HpcInfo -> SDoc
-hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
-hpcInitCode this_mod (HpcInfo tickCount hashNo)
+hpcInitCode :: DynFlags -> Module -> HpcInfo -> SDoc
+hpcInitCode _ _ (NoHpcInfo {}) = Outputable.empty
+hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)
= vcat
[ text "static void hpc_init_" <> ppr this_mod
<> text "(void) __attribute__((constructor));"
@@ -1335,7 +1335,9 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo)
])
]
where
- tickboxes = ppr (mkHpcTicksLabel $ this_mod)
+ platform = targetPlatform dflags
+ bcknd = backend dflags
+ tickboxes = pprCLabel bcknd platform (mkHpcTicksLabel $ this_mod)
module_name = hcat (map (text.charToC) $ BS.unpack $
bytesFS (moduleNameFS (moduleName this_mod)))
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -247,7 +247,7 @@ cgDataCon data_con
, rep_ty <- typePrimRep (scaledThing ty)
, not (isVoidRep rep_ty) ]
- ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
+ ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
-- NB: the closure pointer is assumed *untagged* on
-- entry to a constructor. If the pointer is tagged,
-- then we should not be entering it. This assumption
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -558,7 +558,7 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
= do profile <- getProfile
platform <- getPlatform
let node = idToReg platform (NonVoid bndr)
- slow_lbl = closureSlowEntryLabel cl_info
+ slow_lbl = closureSlowEntryLabel platform cl_info
fast_lbl = closureLocalEntryLabel platform cl_info
-- mkDirectJump does not clobber `Node' containing function closure
jump = mkJump profile NativeNodeCall
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -785,16 +785,16 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
-- Label generation
--------------------------------------
-staticClosureLabel :: ClosureInfo -> CLabel
-staticClosureLabel = toClosureLbl . closureInfoLabel
+staticClosureLabel :: Platform -> ClosureInfo -> CLabel
+staticClosureLabel platform = toClosureLbl platform . closureInfoLabel
-closureSlowEntryLabel :: ClosureInfo -> CLabel
-closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
+closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel
+closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel
closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel
closureLocalEntryLabel platform
- | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel
- | otherwise = toEntryLbl . closureInfoLabel
+ | platformTablesNextToCode platform = toInfoLbl platform . closureInfoLabel
+ | otherwise = toEntryLbl platform . closureInfoLabel
mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel
mkClosureInfoTableLabel platform id lf_info
=====================================
compiler/GHC/StgToCmm/Heap.hs
=====================================
@@ -333,17 +333,19 @@ entryHeapCheck :: ClosureInfo
-> FCode ()
-> FCode ()
-entryHeapCheck cl_info nodeSet arity args code
- = entryHeapCheck' is_fastf node arity args code
- where
+entryHeapCheck cl_info nodeSet arity args code = do
+ platform <- getPlatform
+ let
node = case nodeSet of
Just r -> CmmReg (CmmLocal r)
- Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+ Nothing -> CmmLit (CmmLabel $ staticClosureLabel platform cl_info)
is_fastf = case closureFunInfo cl_info of
Just (_, ArgGen _) -> False
_otherwise -> True
+ entryHeapCheck' is_fastf node arity args code
+
-- | lower-level version for "GHC.Cmm.Parser"
entryHeapCheck' :: Bool -- is a known function pattern
-> CmmExpr -- expression for the closure pointer
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -617,15 +617,15 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
conv = if nodeMustPointToIt profile lf_info then NativeNodeCall
else NativeDirectCall
(offset, _, _) = mkCallEntry profile conv args' []
- ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
+ ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs)
}
-- Data constructors need closures, but not with all the argument handling
-- needed for functions. The shared part goes here.
-emitClosureAndInfoTable ::
- CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
-emitClosureAndInfoTable info_tbl conv args body
+emitClosureAndInfoTable
+ :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable platform info_tbl conv args body
= do { (_, blks) <- getCodeScoped body
- ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
+ ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)
; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
}
=====================================
rts/Hpc.c
=====================================
@@ -241,8 +241,8 @@ startupHpc(void)
/*
* Called on a per-module basis, by a constructor function compiled
- * with each module (see Coverage.hpcInitCode), declaring where the
- * tix boxes are stored in memory. This memory can be uninitized,
+ * with each module (see GHC.HsToCore.Coverage.hpcInitCode), declaring
+ * where the tix boxes are stored in memory. This memory can be uninitized,
* because we will initialize it with either the contents of the tix
* file, or all zeros.
*
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/380638a33691ba43fdcd2e18bca636750e5f66f1...3b15dc3cfb1a33e3d4d952af62d4d0b841a731f5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/380638a33691ba43fdcd2e18bca636750e5f66f1...3b15dc3cfb1a33e3d4d952af62d4d0b841a731f5
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/20200801/57969d28/attachment-0001.html>
More information about the ghc-commits
mailing list