diff options
36 files changed, 413 insertions, 247 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 9e9bae93c6..d0564e6f68 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -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 diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 3bbd06f5c6..dafaea3156 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -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) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 723f7fc4cc..b9981f247b 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -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)]) -- diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 11e68bd4e1..8aa3a79bc8 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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 diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 904e19ad99..dca57dca01 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -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 diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 87cda6a9ad..830f536891 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -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. diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index efc89fe04a..b0dd9b11b8 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -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 [])) } diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index ccfab85a5a..b4dd869039 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -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 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index e3ea52acec..887a876b56 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 7a673b8ec3..3367cdaf45 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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 = diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index aa3a0c3f1e..fb79a9d973 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -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) diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index b306748d23..3c1af4f587 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index d7ddf804f2..1de630ef10 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -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" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 33770b92f6..a1d36a6b54 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b8705603c7..39f4a0487f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 53c6f626e5..a6d263781c 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 879b035d03..303e8dee90 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -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 diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index 1b57a504bd..b3988026be 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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 = [] diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs index 35ee9c90ab..6bf49f0e0d 100644 --- a/compiler/nativeGen/Dwarf.hs +++ b/compiler/nativeGen/Dwarf.hs @@ -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 diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs index abded88468..8647253c26 100644 --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -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 diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index e2d86a93aa..56025f44ac 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -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), diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 99f9ab77ea..0fbce8ccd9 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -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 diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs index 90a3b303f4..b2e574af4c 100644 --- a/compiler/nativeGen/PprBase.hs +++ b/compiler/nativeGen/PprBase.hs @@ -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" diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 330d4fae10..a6d3f9484e 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -342,8 +342,8 @@ genSwitch dflags expr targets generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr) generateJumpTableForInstr dflags (JMP_TBL _ ids label) = - let jumpTable = map (jumpTableEntry dflags) ids - in Just (CmmData ReadOnlyData (Statics label jumpTable)) + let jumpTable = map (jumpTableEntry dflags) ids + in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable)) generateJumpTableForInstr _ _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 566cc337b7..a7085588e9 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -86,7 +86,7 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA ReadOnlyData $ Statics lbl + LDATA (Section ReadOnlyData lbl) $ Statics lbl [CmmStaticLit (CmmFloat f W32)], -- load the literal @@ -99,7 +99,7 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData $ Statics lbl + LDATA (Section ReadOnlyData lbl) $ Statics lbl [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index b9462dfa19..93beabef10 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -13,7 +13,6 @@ module SPARC.Ppr ( pprNatCmmDecl, pprBasicBlock, - pprSectionHeader, pprData, pprInstr, pprFormat, @@ -53,7 +52,7 @@ import Data.Word 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 @@ -62,28 +61,31 @@ 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) $$ pprLabel lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock top_info) blocks) Just (Statics info_lbl _) -> sdocWithPlatform $ \platform -> (if platformHasSubsectionsViaSymbols platform - then pprSectionHeader Text $$ + then pprSectionAlign dspSection $$ 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) + +dspSection :: Section +dspSection = Section Text $ + panic "subsections-via-symbols doesn't combine with split-sections" pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc pprBasicBlock info_env (BasicBlock blockid instrs) @@ -94,7 +96,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 @@ -320,17 +322,19 @@ pprImm imm -- On SPARC all the data sections must be at least 8 byte aligned -- incase we store doubles in them. -- -pprSectionHeader :: Section -> SDoc -pprSectionHeader seg = case seg of - Text -> text ".text\n\t.align 4" - Data -> text ".data\n\t.align 8" - ReadOnlyData -> text ".text\n\t.align 8" - RelocatableReadOnlyData - -> text ".text\n\t.align 8" - UninitialisedData -> text ".bss\n\t.align 8" - ReadOnlyData16 -> text ".data\n\t.align 16" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" - +pprSectionAlign :: Section -> SDoc +pprSectionAlign sec@(Section seg _) = + sdocWithPlatform $ \platform -> + pprSectionHeader platform sec $$ + ptext (case seg of + Text -> sLit ".align 4" + Data -> sLit ".align 8" + ReadOnlyData -> sLit ".align 8" + RelocatableReadOnlyData + -> sLit ".align 8" + UninitialisedData -> sLit ".align 8" + ReadOnlyData16 -> sLit ".align 16" + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section") -- | Pretty print a data item. pprDataItem :: CmmLit -> SDoc diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 30ecc2db8b..2d22734378 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1224,6 +1224,7 @@ isOperand _ _ = False memConstant :: Int -> CmmLit -> NatM Amode memConstant align lit = do lbl <- getNewLabelNat + let rosection = Section ReadOnlyData lbl dflags <- getDynFlags (addr, addr_code) <- if target32Bit (targetPlatform dflags) then do dynRef <- cmmMakeDynamicReference @@ -1234,7 +1235,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) + LDATA rosection (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -2599,50 +2600,48 @@ genSwitch dflags expr targets (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) lbl <- getNewLabelNat dflags <- getDynFlags + let is32bit = target32Bit (targetPlatform dflags) + os = platformOS (targetPlatform dflags) + -- Might want to use .rodata.<function we're in> instead, but as + -- long as it's something unique it'll work out since the + -- references to the jump table are in the appropriate section. + rosection = case os of + -- on Mac OS X/x86_64, put the jump table in the text section to + -- work around a limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous label in its section. + OSDarwin | not is32bit -> Section Text lbl + _ -> Section ReadOnlyData lbl dynRef <- cmmMakeDynamicReference dflags DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) - return $ if target32Bit (targetPlatform dflags) + return $ if is32bit || os == OSDarwin then e_code `appOL` t_code `appOL` toOL [ ADD (intFormat (wordWidth dflags)) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + JMP_TBL (OpReg tableReg) ids rosection lbl + ] + else -- HACK: On x86_64 binutils<2.17 is only able to generate + -- PC32 relocations, hence we only get 32-bit offsets in + -- the jump table. As these offsets are always negative + -- we need to properly sign extend them to 64-bit. This + -- hack should be removed in conjunction with the hack in + -- PprMach.hs/pprDataItem once binutils 2.17 is standard. + e_code `appOL` t_code `appOL` toOL [ + MOVSxL II32 op (OpReg reg), + ADD (intFormat (wordWidth dflags)) (OpReg reg) + (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids rosection lbl ] - else case platformOS (targetPlatform dflags) of - OSDarwin -> - -- on Mac OS X/x86_64, put the jump table - -- in the text section to work around a - -- limitation of the linker. - -- ld64 is unable to handle the relocations for - -- .quad L1 - L0 - -- if L0 is not preceded by a non-anonymous - -- label in its section. - e_code `appOL` t_code `appOL` toOL [ - ADD (intFormat (wordWidth dflags)) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids Text lbl - ] - _ -> - -- HACK: On x86_64 binutils<2.17 is only able - -- to generate PC32 relocations, hence we only - -- get 32-bit offsets in the jump table. As - -- these offsets are always negative we need - -- to properly sign extend them to 64-bit. - -- This hack should be removed in conjunction - -- with the hack in PprMach.hs/pprDataItem - -- once binutils 2.17 is standard. - e_code `appOL` t_code `appOL` toOL [ - MOVSxL II32 op (OpReg reg), - ADD (intFormat (wordWidth dflags)) (OpReg reg) (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl - ] | otherwise = do (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) lbl <- getNewLabelNat let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ - JMP_TBL op ids ReadOnlyData lbl + JMP_TBL op ids (Section ReadOnlyData lbl) lbl ] return code where (offset, ids) = switchTargetsToTable targets diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 0c9507ab28..1a1fd86c00 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -11,8 +11,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module X86.Ppr ( pprNatCmmDecl, - pprBasicBlock, - pprSectionHeader, pprData, pprInstr, pprFormat, @@ -53,7 +51,7 @@ import Data.Bits pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) = - pprSectionHeader section $$ pprDatas dats + pprSectionAlign section $$ pprDatas dats pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = sdocWithDynFlags $ \dflags -> @@ -63,7 +61,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) $$ pprLabel lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock top_info) blocks) $$ (if gopt Opt_Debug dflags @@ -72,21 +70,20 @@ 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) $$ (if gopt Opt_Debug dflags then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$ pprSizeDecl info_lbl @@ -96,8 +93,7 @@ pprSizeDecl :: CLabel -> SDoc pprSizeDecl lbl = sdocWithPlatform $ \platform -> if osElfTarget (platformOS platform) - then ptext (sLit "\t.size") <+> ppr lbl - <> ptext (sLit ", .-") <> ppr lbl + then ptext (sLit "\t.size") <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl else empty pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc @@ -113,7 +109,6 @@ pprBasicBlock info_env (BasicBlock blockid instrs) maybe_infotable = case mapLookup blockid info_env of Nothing -> empty Just (Statics info_lbl info) -> - pprSectionHeader Text $$ infoTableLoc $$ vcat (map pprData info) $$ pprLabel info_lbl @@ -384,56 +379,34 @@ pprAddr (AddrBaseIndex base index displacement) ppr_disp (ImmInt 0) = empty ppr_disp imm = pprImm imm - -pprSectionHeader :: Section -> SDoc -pprSectionHeader seg = - sdocWithPlatform $ \platform -> - case platformOS platform of - OSDarwin - | target32Bit platform -> - case seg of - Text -> text ".text\n\t.align 2" - Data -> text ".data\n\t.align 2" - ReadOnlyData -> text ".const\n\t.align 2" - RelocatableReadOnlyData - -> text ".const_data\n\t.align 2" - UninitialisedData -> text ".data\n\t.align 2" - ReadOnlyData16 -> text ".const\n\t.align 4" - OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" - | otherwise -> - case seg of - Text -> text ".text\n\t.align 3" - Data -> text ".data\n\t.align 3" - ReadOnlyData -> text ".const\n\t.align 3" - RelocatableReadOnlyData - -> text ".const_data\n\t.align 3" - UninitialisedData -> text ".data\n\t.align 3" - ReadOnlyData16 -> text ".const\n\t.align 4" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" - _ - | target32Bit platform -> - case seg of - Text -> text ".text\n\t.align 4,0x90" - Data -> text ".data\n\t.align 4" - ReadOnlyData -> text ".section .rodata\n\t.align 4" - RelocatableReadOnlyData - -> text ".section .data\n\t.align 4" - UninitialisedData -> text ".section .bss\n\t.align 4" - ReadOnlyData16 -> text ".section .rodata\n\t.align 16" - OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" - | otherwise -> - case seg of - Text -> text ".text\n\t.align 8" - Data -> text ".data\n\t.align 8" - ReadOnlyData -> text ".section .rodata\n\t.align 8" - RelocatableReadOnlyData - -> text ".section .data\n\t.align 8" - UninitialisedData -> text ".section .bss\n\t.align 8" - ReadOnlyData16 -> text ".section .rodata.cst16\n\t.align 16" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" - - - +-- | Print section header and appropriate alignment for that section. +pprSectionAlign :: Section -> SDoc +pprSectionAlign (Section (OtherSection _) _) = + panic "X86.Ppr.pprSectionAlign: unknown section" +pprSectionAlign sec@(Section seg _) = + sdocWithPlatform $ \platform -> + pprSectionHeader platform sec $$ + ptext (sLit ".align ") <> + case platformOS platform of + OSDarwin + | target32Bit platform -> + case seg of + ReadOnlyData16 -> int 4 + _ -> int 2 + | otherwise -> + case seg of + ReadOnlyData16 -> int 4 + _ -> int 3 + _ + | target32Bit platform -> + case seg of + Text -> ptext (sLit "4,0x90") + ReadOnlyData16 -> int 16 + _ -> int 4 + | otherwise -> + case seg of + ReadOnlyData16 -> int 16 + _ -> int 8 pprDataItem :: CmmLit -> SDoc pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst index 8945e3bbe7..27b54cb0a8 100644 --- a/docs/users_guide/phases.rst +++ b/docs/users_guide/phases.rst @@ -613,6 +613,20 @@ for example). the library itself (the ``.a`` file) can be a factor of 2 to 2.5 larger. We use this feature for building GHC's libraries. +``-split-sections`` + .. index:: + single: -split-sections + + Place each generated function or data item into its own section in the + output file if the target supports arbitrary sections. The name of the + function or the name of the data item determines the section's name in the + output file. + + When linking, the linker can automatically remove all unreferenced sections + and thus produce smaller executables. The effect is similar to + ``-split-objs``, but somewhat more efficient - the generated library files + are about 30% smaller than with ``-split-objs``. + ``-static`` .. index:: single: -static diff --git a/driver/utils/merge_sections.ld b/driver/utils/merge_sections.ld new file mode 100644 index 0000000000..8c82ca09b5 --- /dev/null +++ b/driver/utils/merge_sections.ld @@ -0,0 +1,26 @@ +/* Linker script to undo -split-sections and merge all sections together when + * linking relocatable object files for GHCi. + * ld -r normally retains the individual sections, which is what you would want + * if the intention is to eventually link into a binary with --gc-sections, but + * it doesn't have a flag for directly doing what we want. */ +SECTIONS +{ + .text : { + *(.text*) + } + .rodata.cst16 : { + *(.rodata.cst16*) + } + .rodata : { + *(.rodata*) + } + .data.rel.ro : { + *(.data.rel.ro*) + } + .data : { + *(.data*) + } + .bss : { + *(.bss*) + } +} diff --git a/mk/config.mk.in b/mk/config.mk.in index 0a9f92b64d..035443a5fd 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -302,6 +302,17 @@ SupportsSplitObjs := $(strip \ SplitObjs=$(SupportsSplitObjs) # ---------------------------------------------------------------------------- +# Section splitting +# +# Similar to -ffunction-sections -fdata-sections in GCC. Provides space saving +# like SplitObjs, but doesn't require post-processing and splitting of object +# files. +# +# Set SplitSections=YES in your build.mk to enable. + +SplitSections=NO + +# ---------------------------------------------------------------------------- # There are a number of things which technically depend on GHC (e.g. if # ghc changes then Haskell files may be compiled differently, or Cabal diff --git a/rts/ghc.mk b/rts/ghc.mk index c7c5e75831..1f5f996906 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -334,6 +334,10 @@ ifeq "$$(TargetOS_CPP)" "mingw32" rts_CC_OPTS += -DWINVER=$(rts_WINVER) endif +ifeq "$(SplitSections)" "YES" +rts_CC_OPTS += -ffunction-sections -fdata-sections +endif + #----------------------------------------------------------------------------- # Flags for compiling specific files rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\" diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index a10e53833e..d048f74b95 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -136,6 +136,8 @@ BINDIST_LIBS += $$($1_$2_$3_LIB) BINDIST_LIBS += $$($1_$2_$3_LIB0) endif +$1_$2_LD_SCRIPT = driver/utils/merge_sections.ld + # Build the GHCi library ifeq "$$(DYNAMIC_GHC_PROGRAMS)" "YES" $1_$2_GHCI_LIB = $$($1_$2_dyn_LIB) @@ -148,8 +150,8 @@ ifneq "$4" "0" BINDIST_LIBS += $$($1_$2_GHCI_LIB) endif endif -$$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) - $$(call cmd,LD) $$(CONF_LD_LINKER_OPTS_STAGE$4) -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) +$$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) $$($1_$2_LD_SCRIPT) + $$(call cmd,LD) $$(CONF_LD_LINKER_OPTS_STAGE$4) -r $(if $(filter YES,$(LdIsGNULd)),-T $$($1_$2_LD_SCRIPT)) -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES" # Don't bother making ghci libs for bootstrapping packages diff --git a/rules/build-package.mk b/rules/build-package.mk index 688e1d2ca5..9599c57eb3 100644 --- a/rules/build-package.mk +++ b/rules/build-package.mk @@ -110,6 +110,15 @@ else $1_$2_SplitObjs = NO endif endif +# Disable split sections when building with stage0, it won't be supported yet +# and it's probably not very relevant anyway (smaller stage1 ghc?). +ifeq "$$($1_$2_SplitSections)" "" +ifeq "$3" "1" +$1_$2_SplitSections = $(SplitSections) +else +$1_$2_SplitSections = NO +endif +endif $(call hs-sources,$1,$2) $(call c-sources,$1,$2) diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index 920ff07f20..47f6f90237 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -136,6 +136,7 @@ $1_$2_$3_ALL_HC_OPTS = \ -hisuf $$($3_hisuf) -osuf $$($3_osuf) -hcsuf $$($3_hcsuf) \ $$($1_$2_$3_MOST_DIR_HC_OPTS) \ $$(if $$(findstring YES,$$($1_$2_SplitObjs)),$$(if $$(findstring dyn,$3),,-split-objs),) \ + $$(if $$(findstring YES,$$($1_$2_SplitSections)),$$(if $$(findstring dyn,$3),,-split-sections),) \ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),$$(if $$(findstring v,$3),-dynamic-too)) ifeq "$3" "dyn" diff --git a/utils/mkUserGuidePart/Options/Linking.hs b/utils/mkUserGuidePart/Options/Linking.hs index cc42db80ff..14c4783585 100644 --- a/utils/mkUserGuidePart/Options/Linking.hs +++ b/utils/mkUserGuidePart/Options/Linking.hs @@ -105,6 +105,10 @@ linkingOptions = , flagDescription = "Split objects (for libraries)" , flagType = DynamicFlag } + , flag { flagName = "-split-sections" + , flagDescription = "Split sections for link-time dead-code stripping" + , flagType = DynamicFlag + } , flag { flagName = "-static" , flagDescription = "Use static Haskell libraries" , flagType = DynamicFlag |