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

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
This diff is collapsed.
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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
--------------------------------------------------------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
}
......@@ -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.
*
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment