Commit 4a32bf92 authored by olsner's avatar olsner Committed by Ben Gamari

Implement function-sections for Haskell code, #8405

This adds a flag -split-sections that does similar things to
-split-objs, but using sections in single object files instead of
relying on the Satanic Splitter and other abominations. This is very
similar to the GCC flags -ffunction-sections and -fdata-sections.

The --gc-sections linker flag, which allows unused sections to actually
be removed, is added to all link commands (if the linker supports it) so
that space savings from having base compiled with sections can be
realized.

Supported both in LLVM and the native code-gen, in theory for all
architectures, but really tested on x86 only.

In the GHC build, a new SplitSections variable enables -split-sections
for relevant parts of the build.

Test Plan: validate with both settings of SplitSections

Reviewers: dterei, Phyx, austin, simonmar, thomie, bgamari

Reviewed By: simonmar, thomie, bgamari

Subscribers: hsyl20, erikd, kgardas, thomie

Differential Revision: https://phabricator.haskell.org/D1242

GHC Trac Issues: #8405
parent 9bea234d
......@@ -8,7 +8,7 @@ module Cmm (
CmmGraph, GenCmmGraph(..),
CmmBlock,
RawCmmDecl, RawCmmGroup,
Section(..), CmmStatics(..), CmmStatic(..),
Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
-- ** Blocks containing lists
GenBasicBlock(..), blockId,
......@@ -48,8 +48,10 @@ import Data.Word ( Word8 )
-- A CmmProgram is a list of CmmGroups
-- A CmmGroup is a list of top-level declarations
-- When object-splitting is on,each group is compiled into a separate
-- When object-splitting is on, each group is compiled into a separate
-- .o file. So typically we put closely related stuff in a CmmGroup.
-- Section-splitting follows suit and makes one .text subsection for each
-- CmmGroup.
type CmmProgram = [CmmGroup]
......@@ -163,7 +165,7 @@ needsSRT (C_SRT _ _ _) = True
-- Static Data
-----------------------------------------------------------------------------
data Section
data SectionType
= Text
| Data
| ReadOnlyData
......@@ -171,6 +173,9 @@ data Section
| UninitialisedData
| ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned
| OtherSection String
deriving (Show)
data Section = Section SectionType CLabel
data CmmStatic
= CmmStaticLit CmmLit
......
......@@ -148,8 +148,9 @@ addCAF caf srt =
where last = next_elt srt
srtToData :: TopSRT -> CmmGroup
srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]
where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
sec = Section RelocatableReadOnlyData (lbl srt)
-- Once we have found the CAFs, we need to do two things:
-- 1. Build a table of all the CAFs used in the procedure.
......@@ -223,7 +224,8 @@ to_SRT dflags top_srt off len bmp
| len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
section = Section RelocatableReadOnlyData srt_desc_lbl
tbl = CmmData section $
Statics srt_desc_lbl $ map CmmStaticLit
( cmmLabelOffW dflags top_srt off
: mkWordCLit dflags (fromIntegral len)
......
......@@ -133,7 +133,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
--
return (top_decls ++
[CmmProc mapEmpty entry_lbl live blocks,
mkDataLits Data info_lbl
mkDataLits (Section Data info_lbl) info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
--
......
......@@ -385,7 +385,7 @@ cmmdata :: { CmmParse () }
: 'section' STRING '{' data_label statics '}'
{ do lbl <- $4;
ss <- sequence $5;
code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
data_label :: { CmmParse CLabel }
: NAME ':'
......@@ -834,7 +834,7 @@ typenot8 :: { CmmType }
| 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
{
section :: String -> Section
section :: String -> SectionType
section "text" = Text
section "data" = Data
section "rodata" = ReadOnlyData
......
......@@ -162,9 +162,10 @@ mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stm
-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit uniq bytes
= (CmmLabel lbl, CmmData ReadOnlyData $ Statics lbl [CmmString bytes])
= (CmmLabel lbl, CmmData sec $ Statics lbl [CmmString bytes])
where
lbl = mkStringLitLabel uniq
sec = Section ReadOnlyData lbl
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
-- Build a data-segment data block
mkDataLits section lbl lits
......@@ -175,8 +176,8 @@ mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkRODataLits lbl lits
= mkDataLits section lbl lits
where
section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
| otherwise = Section ReadOnlyData lbl
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
......
......@@ -154,14 +154,20 @@ pprStatic s = case s of
-- data sections
--
pprSection :: Section -> SDoc
pprSection s = case s of
Text -> section <+> doubleQuotes (text "text")
Data -> section <+> doubleQuotes (text "data")
ReadOnlyData -> section <+> doubleQuotes (text "readonly")
ReadOnlyData16 -> section <+> doubleQuotes (text "readonly16")
RelocatableReadOnlyData
-> section <+> doubleQuotes (text "relreadonly")
UninitialisedData -> section <+> doubleQuotes (text "uninitialised")
OtherSection s' -> section <+> doubleQuotes (text s')
where
pprSection (Section t suffix) =
section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)
where
section = ptext (sLit "section")
pprSectionType :: SectionType -> SDoc
pprSectionType s = doubleQuotes (ptext t)
where
t = case s of
Text -> sLit "text"
Data -> sLit "data"
ReadOnlyData -> sLit "readonly"
ReadOnlyData16 -> sLit "readonly16"
RelocatableReadOnlyData
-> sLit "relreadonly"
UninitialisedData -> sLit "uninitialised"
OtherSection s' -> sLit s' -- Not actually a literal though.
......@@ -194,7 +194,8 @@ mkModuleInit cost_centre_info this_mod hpc_info
; initCostCentres cost_centre_info
-- For backwards compatibility: user code may refer to this
-- label for calling hs_add_root().
; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) []))
; let lbl = mkPlainModuleInitLabel this_mod
; emitDecl (CmmData (Section Data lbl) (Statics lbl []))
}
......
......@@ -306,7 +306,7 @@ baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg)
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a data-segment data block
emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits)
emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a read-only data block
......
......@@ -462,6 +462,9 @@ endif
compiler_stage1_SplitObjs = NO
compiler_stage2_SplitObjs = NO
compiler_stage3_SplitObjs = NO
compiler_stage1_SplitSections = NO
compiler_stage2_SplitSections = NO
compiler_stage3_SplitSections = NO
# There are too many symbols in the ghc package for a Windows DLL.
# We therefore need to split some of the modules off into a separate
......
......@@ -26,7 +26,7 @@ module LlvmCodeGen.Base (
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams,
llvmPtrBits, tysToParams, llvmFunSection,
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls,
......@@ -140,6 +140,12 @@ llvmFunAlign dflags = Just (wORD_SIZE dflags)
llvmInfAlign :: DynFlags -> LMAlign
llvmInfAlign dflags = Just (wORD_SIZE dflags)
-- | Section to use for a function
llvmFunSection :: DynFlags -> LMString -> LMSection
llvmFunSection dflags lbl
| gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
| otherwise = Nothing
-- | A Function's arguments
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs dflags live =
......
......@@ -144,7 +144,9 @@ getInstrinct2 fname fty@(LMFunction funSig) = do
return []
Nothing -> do
funInsert fname fty
return [CmmData Data [([],[fty])]]
un <- runUs getUniqueM
let lbl = mkAsmTempLabel un
return [CmmData (Section Data lbl) [([],[fty])]]
return (fv, nilOL, tops)
......
......@@ -15,6 +15,7 @@ import LlvmCodeGen.Base
import BlockId
import CLabel
import Cmm
import DynFlags
import FastString
import Outputable
......@@ -36,6 +37,7 @@ genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
genLlvmData (sec, Statics lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
lmsec <- llvmSection sec
let types = map getStatType static
strucTy = LMStruct types
......@@ -45,21 +47,43 @@ genLlvmData (sec, Statics lbl xs) = do
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
const = if isSecConstant sec then Constant else Global
varDef = LMGlobalVar label tyAlias link Nothing Nothing const
varDef = LMGlobalVar label tyAlias link lmsec Nothing const
globDef = LMGlobal varDef struct
return ([globDef], [tyAlias])
-- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool
isSecConstant Text = True
isSecConstant ReadOnlyData = True
isSecConstant RelocatableReadOnlyData = True
isSecConstant ReadOnlyData16 = True
isSecConstant Data = False
isSecConstant UninitialisedData = False
isSecConstant (OtherSection _) = False
isSecConstant (Section t _) = case t of
Text -> True
ReadOnlyData -> True
RelocatableReadOnlyData -> True
ReadOnlyData16 -> True
Data -> False
UninitialisedData -> False
(OtherSection _) -> False
-- | Format the section type part of a Cmm Section
llvmSectionType :: SectionType -> FastString
llvmSectionType t = case t of
Text -> fsLit ".text"
ReadOnlyData -> fsLit ".rodata"
RelocatableReadOnlyData -> fsLit ".data.rel.ro"
ReadOnlyData16 -> fsLit ".rodata.cst16"
Data -> fsLit ".data"
UninitialisedData -> fsLit ".bss"
(OtherSection _) -> panic "llvmSectionType: unknown section type"
-- | Format a Cmm Section into a LLVM section name
llvmSection :: Section -> LlvmM LMSection
llvmSection (Section t suffix) = do
dflags <- getDynFlags
let splitSect = gopt Opt_SplitSections dflags
if not splitSect
then return Nothing
else do
lmsuffix <- strCLabel_llvm suffix
return (Just (concatFS [llvmSectionType t, fsLit ".", lmsuffix]))
-- ----------------------------------------------------------------------------
-- * Generate static data
......
......@@ -114,6 +114,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
dflags <- getDynFlags
let buildArg = fsLit . showSDoc dflags . ppPlainName
funArgs = map buildArg (llvmFunArgs dflags live)
funSect = llvmFunSection dflags (decName funDec)
-- generate the info table
prefix <- case mb_info of
......@@ -123,7 +124,8 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
let infoTy = LMStruct $ map getStatType infoStatics
return $ Just $ LMStaticStruc infoStatics infoTy
let fun = LlvmFunction funDec funArgs llvmStdFunAttrs Nothing
let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
prefix lmblocks
name = decName $ funcDecl fun
defName = name `appendFS` fsLit "$def"
......
......@@ -1908,6 +1908,10 @@ linkBinary' staticLink dflags o_files dep_packages = do
then ["-Wl,-read_only_relocs,suppress"]
else [])
++ (if sLdIsGnuLd mySettings
then ["-Wl,--gc-sections"]
else [])
++ o_files
++ lib_path_opts)
++ extra_ld_inputs
......
......@@ -391,6 +391,7 @@ data GeneralFlag
| Opt_EagerBlackHoling
| Opt_NoHsMain
| Opt_SplitObjs
| Opt_SplitSections
| Opt_StgStats
| Opt_HideAllPackages
| Opt_PrintBindResult
......@@ -1283,7 +1284,10 @@ wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting objects
-- when we're going to be dynamically
-- linking. Plus it breaks compilation
-- on OSX x86.
Opt_SplitObjs]
Opt_SplitObjs,
-- If splitobjs wasn't useful for this,
-- assume sections aren't either.
Opt_SplitSections]
wayUnsetGeneralFlags _ WayProf = []
wayUnsetGeneralFlags _ WayEventLog = []
......@@ -2326,6 +2330,15 @@ dynamic_flags = [
then setGeneralFlag Opt_SplitObjs
else addWarn "ignoring -fsplit-objs"))
, defGhcFlag "split-sections"
(noArgM (\dflags -> do
if platformHasSubsectionsViaSymbols (targetPlatform dflags)
then do addErr $
"-split-sections is not useful on this platform " ++
"since it always uses subsections via symbols."
return dflags
else return (gopt_set dflags Opt_SplitSections)))
-------- ghc -M -----------------------------------------------------
, defGhcFlag "dep-suffix" (hasArg addDepSuffix)
, defGhcFlag "dep-makefile" (hasArg setDepMakefile)
......
......@@ -1434,7 +1434,7 @@ doCodeGen hsc_env this_mod data_tycons
-- we generate one SRT for the whole module.
let
pipeline_stream
| gopt Opt_SplitObjs dflags
| gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags
= {-# SCC "cmmPipeline" #-}
let run_pipeline us cmmgroup = do
let (topSRT', us') = initUs us emptySRT
......
......@@ -791,6 +791,7 @@ getLinkerInfo' dflags = do
-- GNU ld specifically needs to use less memory. This especially
-- hurts on small object files. Trac #5240.
-- Set DT_NEEDED for all shared libraries. Trac #10110.
-- TODO: Investigate if these help or hurt when using split sections.
return (GnuLD $ map Option ["-Wl,--hash-size=31",
"-Wl,--reduce-memory-overheads",
-- ELF specific flag
......
......@@ -373,10 +373,10 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
dbgMap = debugToMap ndbgs
-- Insert split marker, generate native code
let splitFlag = gopt Opt_SplitObjs dflags
let splitObjs = gopt Opt_SplitObjs dflags
split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $
ofBlockList (panic "split_marker_entry") []
cmms' | splitFlag = split_marker : cmms
cmms' | splitObjs = split_marker : cmms
| otherwise = cmms
(ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
cmms' ngs 0
......@@ -388,8 +388,10 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
-- Emit & clear DWARF information when generating split
-- object files, as we need it to land in the same object file
-- When using split sections, note that we do not split the debug
-- info but emit all the info at once in finishNativeGen.
(ngs'', us'') <-
if debugFlag && splitFlag
if debugFlag && splitObjs
then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs
emitNativeCode dflags h dwarf
return (ngs' { ngs_debug = []
......
......@@ -83,11 +83,22 @@ dwarfGen df modLoc us blocks = do
pprDwarfFrame (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
let aranges = dwarfARangesSection $$
pprDwarfARange (DwarfARange lowLabel highLabel unitU)
let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
| otherwise = [DwarfARange lowLabel highLabel]
let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
-- | Build an address range entry for one proc.
-- With split sections, each proc needs its own entry, since they may get
-- scattered in the final binary. Without split sections, we could make a
-- single arange based on the first/last proc.
mkDwarfARange :: DebugBlock -> DwarfARange
mkDwarfARange proc = DwarfARange start end
where
start = dblCLabel proc
end = mkAsmTempEndLabel start
-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: Unique -> SDoc
......
......@@ -5,7 +5,7 @@ module Dwarf.Types
, pprAbbrevDecls
-- * Dwarf address range table
, DwarfARange(..)
, pprDwarfARange
, pprDwarfARanges
-- * Dwarf frame
, DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
, pprDwarfFrame
......@@ -159,14 +159,12 @@ data DwarfARange
= DwarfARange
{ dwArngStartLabel :: CLabel
, dwArngEndLabel :: CLabel
, dwArngUnitUnique :: Unique
-- ^ from which the corresponding label in @.debug_info@ is derived
}
-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = sdocWithPlatform $ \plat ->
pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
let wordSize = platformWordSize plat
paddingSize = 4 :: Int
-- header is 12 bytes long.
......@@ -174,22 +172,25 @@ pprDwarfARange arng = sdocWithPlatform $ \plat ->
-- pad such that first entry begins at multiple of entry size.
pad n = vcat $ replicate n $ pprByte 0
initialLength = 8 + paddingSize + 2*2*wordSize
length = ppr (dwArngEndLabel arng)
<> char '-' <> ppr (dwArngStartLabel arng)
in pprDwWord (ppr initialLength)
$$ pprHalf 2
$$ sectionOffset (ppr $ mkAsmTempLabel $ dwArngUnitUnique arng)
$$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
-- beginning of body
$$ pprWord (ppr $ dwArngStartLabel arng)
$$ pprWord length
-- body
$$ vcat (map pprDwarfARange arngs)
-- terminus
$$ pprWord (char '0')
$$ pprWord (char '0')
pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
where
length = ppr (dwArngEndLabel arng)
<> char '-' <> ppr (dwArngStartLabel arng)
-- | Information about unwind instructions for a procedure. This
-- corresponds to a "Common Information Entry" (CIE) in DWARF.
data DwarfFrame
......
......@@ -650,8 +650,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do
Amode addr addr_code <- getAmode D dynRef
let format = floatFormat frep
code dst =
LDATA ReadOnlyData (Statics lbl
[CmmStaticLit (CmmFloat f frep)])
LDATA (Section ReadOnlyData lbl)
(Statics lbl [CmmStaticLit (CmmFloat f frep)])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
......@@ -672,8 +672,7 @@ getRegister' dflags (CmmLit lit)
let rep = cmmLitType dflags lit
format = cmmTypeFormat rep
code dst =
LDATA ReadOnlyData (Statics lbl
[CmmStaticLit lit])
LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
......@@ -1530,7 +1529,7 @@ generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =
jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
where blockLabel = mkAsmTempLabel (getUnique blockid)
in Just (CmmData ReadOnlyData (Statics lbl jumpTable))
in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))
generateJumpTableForInstr _ _ = Nothing
-- -----------------------------------------------------------------------------
......@@ -1721,7 +1720,7 @@ coerceInt2FP' ArchPPC fromRep toRep x = do
Amode addr addr_code <- getAmode D dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA ReadOnlyData $ Statics lbl
LDATA (Section ReadOnlyData lbl) $ Statics lbl
[CmmStaticLit (CmmInt 0x43300000 W32),
CmmStaticLit (CmmInt 0x80000000 W32)],
XORIS itmp src (ImmInt 0x8000),
......
......@@ -7,18 +7,7 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
module PPC.Ppr (
pprNatCmmDecl,
pprBasicBlock,
pprSectionHeader,
pprData,
pprInstr,
pprFormat,
pprImm,
pprDataItem,
)
where
module PPC.Ppr (pprNatCmmDecl) where
import PPC.Regs
import PPC.Instr
......@@ -49,7 +38,7 @@ import Data.Bits
pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
pprNatCmmDecl (CmmData section dats) =
pprSectionHeader section $$ pprDatas dats
pprSectionAlign section $$ pprDatas dats
pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
case topInfoTable proc of
......@@ -59,7 +48,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
[] -> -- special case for split markers:
pprLabel lbl
blocks -> -- special case for code without info table:
pprSectionHeader Text $$
pprSectionAlign (Section Text lbl) $$
(case platformArch platform of
ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl
ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl
......@@ -69,22 +58,21 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
Just (Statics info_lbl _) ->
sdocWithPlatform $ \platform ->
pprSectionAlign (Section Text info_lbl) $$
(if platformHasSubsectionsViaSymbols platform
then pprSectionHeader Text $$
ppr (mkDeadStripPreventer info_lbl) <> char ':'
then ppr (mkDeadStripPreventer info_lbl) <> char ':'
else empty) $$
vcat (map (pprBasicBlock top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
then
-- See Note [Subsections Via Symbols]
text "\t.long "
<+> ppr info_lbl
<+> char '-'
<+> ppr (mkDeadStripPreventer info_lbl)
else empty)
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
then
-- See Note [Subsections Via Symbols]
text "\t.long "
<+> ppr info_lbl
<+> char '-'
<+> ppr (mkDeadStripPreventer info_lbl)
else empty)
pprFunctionDescriptor :: CLabel -> SDoc
pprFunctionDescriptor lab = pprGloblDecl lab
......@@ -124,7 +112,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
maybe_infotable = case mapLookup blockid info_env of
Nothing -> empty
Just (Statics info_lbl info) ->
pprSectionHeader Text $$
pprSectionAlign (Section Text info_lbl) $$
vcat (map pprData info) $$
pprLabel info_lbl
......@@ -314,35 +302,33 @@ pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1,
pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
pprSectionHeader :: Section -> SDoc
pprSectionHeader seg =
pprSectionAlign :: Section -> SDoc
pprSectionAlign sec@(Section seg _) =
sdocWithPlatform $ \platform ->
let osDarwin = platformOS platform == OSDarwin
ppc64 = not $ target32Bit platform
in
case seg of
Text -> text ".text\n\t.align 2"
Data
| ppc64 -> text ".data\n.align 3"
| otherwise -> text ".data\n.align 2"
ReadOnlyData
| osDarwin -> text ".const\n\t.align 2"
| ppc64 -> text ".section .rodata\n\t.align 3"
| otherwise -> text ".section .rodata\n\t.align 2"
RelocatableReadOnlyData
| osDarwin -> text ".const_data\n\t.align 2"
| ppc64 -> text ".data\n\t.align 3"
| otherwise -> text ".data\n\t.align 2"
UninitialisedData
| osDarwin -> text ".const_data\n\t.align 2"
| ppc64 -> text ".section .bss\n\t.align 3"
| otherwise -> text ".section .bss\n\t.align 2"
ReadOnlyData16
| osDarwin -> text ".const\n\t.align 4"
| otherwise -> text ".section .rodata\n\t.align 4"
OtherSection _ ->
panic "PprMach.pprSectionHeader: unknown section"
align = ptext $ case seg of
Text -> sLit ".align 2"
Data
| ppc64 -> sLit ".align 3"
| otherwise -> sLit ".align 2"
ReadOnlyData
| osDarwin -> sLit ".align 2"
| ppc64 -> sLit ".align 3"
| otherwise -> sLit ".align 2"
RelocatableReadOnlyData
| osDarwin -> sLit ".align 2"
| ppc64 -> sLit ".align 3"
| otherwise -> sLit ".align 2"
UninitialisedData
| osDarwin -> sLit ".align 2"
| ppc64 -> sLit ".align 3"
| otherwise -> sLit ".align 2"
ReadOnlyData16
| osDarwin -> sLit ".align 4"
| otherwise -> sLit ".align 4"
OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section"
in pprSectionHeader platform sec $$ align
pprDataItem :: CmmLit -> SDoc
pprDataItem lit
......
......@@ -10,11 +10,19 @@ module PprBase (
castFloatToWord8Array,
castDoubleToWord8Array,
floatToBytes,
doubleToBytes
doubleToBytes,
pprSectionHeader
)
where
import CLabel
import Cmm
import DynFlags
import FastString
import Outputable
import Platform
import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST
......@@ -70,3 +78,45 @@ doubleToBytes d
i7 <- readArray arr 7
return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
)
-- ----------------------------------------------------------------------------
-- Printing section headers.
--
-- If -split-section was specified, include the suffix label, otherwise just
-- print the section type. For Darwin, where subsections-for-symbols are
-- used instead, only print section type.
pprSectionHeader :: Platform -> Section -> SDoc
pprSectionHeader platform (Section t suffix) =
case platformOS platform of
OSDarwin -> pprDarwinSectionHeader t
_ -> pprGNUSectionHeader t suffix
pprGNUSectionHeader :: SectionType -> CLabel -> SDoc
pprGNUSectionHeader t suffix = sdocWithDynFlags $ \dflags ->
let splitSections = gopt Opt_SplitSections dflags
subsection | splitSections = char '.' <> ppr suffix
| otherwise = empty
in ptext (sLit ".section ") <> ptext header <> subsection
where
header = case t of
Text -> sLit ".text"
Data -> sLit ".data"
ReadOnlyData -> sLit ".rodata"
RelocatableReadOnlyData -> sLit ".data.rel.ro"
UninitialisedData -> sLit ".bss"
ReadOnlyData16 -> sLit ".rodata.cst16"
OtherSection _ ->
panic "PprBase.pprGNUSectionHeader: unknown section type"
pprDarwinSectionHeader :: SectionType -> SDoc
pprDarwinSectionHeader t =
ptext $ case t of
Text -> sLit ".text"
Data -> sLit ".data"
ReadOnlyData -> sLit ".const"
RelocatableReadOnlyData -> sLit ".const_data"
UninitialisedData -> sLit ".data"
ReadOnlyData16 -> sLit ".const"
OtherSection _ ->
panic "PprBase.pprDarwinSectionHeader: unknown section type"
......@@ -342,8 +342,8 @@ genSwitch dflags expr targets
generateJumpTableForInstr :: DynFlags -> Instr