summaryrefslogtreecommitdiff
path: root/compiler/nativeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen')
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs8
-rw-r--r--compiler/nativeGen/Dwarf.hs15
-rw-r--r--compiler/nativeGen/Dwarf/Types.hs23
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs11
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs94
-rw-r--r--compiler/nativeGen/PprBase.hs52
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs4
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Gen32.hs4
-rw-r--r--compiler/nativeGen/SPARC/Ppr.hs58
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs61
-rw-r--r--compiler/nativeGen/X86/Ppr.hs111
11 files changed, 233 insertions, 208 deletions
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
View Lorry Controller Status