Commit 56a7c193 authored by Sylvain Henry's avatar Sylvain Henry
Browse files

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.
parent 380638a3
......@@ -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@plt"
SymbolPtr -> text ".LC_" <> ppr lbl
ppLbl <> text "+32768@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.
......
......@@ -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
......
......@@ -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)