Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
a12b6bf8
Commit
a12b6bf8
authored
Jun 12, 2012
by
Ian Lynagh
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Use SDoc rather than Doc in the native gens
This avoid lots of converting back and forth between the two types.
parent
ffa6d17c
Changes
9
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
236 additions
and
279 deletions
+236
-279
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/AsmCodeGen.lhs
+25
-26
compiler/nativeGen/PIC.hs
compiler/nativeGen/PIC.hs
+39
-54
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/PPC/Ppr.hs
+42
-44
compiler/nativeGen/PPC/Regs.hs
compiler/nativeGen/PPC/Regs.hs
+6
-8
compiler/nativeGen/PprBase.hs
compiler/nativeGen/PprBase.hs
+0
-17
compiler/nativeGen/SPARC/Imm.hs
compiler/nativeGen/SPARC/Imm.hs
+2
-3
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/SPARC/Ppr.hs
+45
-47
compiler/nativeGen/X86/Ppr.hs
compiler/nativeGen/X86/Ppr.hs
+75
-77
compiler/nativeGen/X86/Regs.hs
compiler/nativeGen/X86/Regs.hs
+2
-3
No files found.
compiler/nativeGen/AsmCodeGen.lhs
View file @
a12b6bf8
...
...
@@ -64,7 +64,6 @@ import Util
import BasicTypes ( Alignment )
import Digraph
import Pretty (Doc)
import qualified Pretty
import BufWrite
import Outputable
...
...
@@ -114,7 +113,7 @@ The machine-dependent bits break down as follows:
machine instructions.
* ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
a 'Doc').
a '
S
Doc').
* ["RegAllocInfo"] In the register allocator, we manipulate
'MRegsState's, which are 'BitSet's, one bit per machine register.
...
...
@@ -139,7 +138,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
canShortcut :: instr -> Maybe jumpDest,
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
pprNatCmmDecl :: Platform -> NatCmmDecl statics instr -> Doc,
pprNatCmmDecl :: Platform -> NatCmmDecl statics instr ->
S
Doc,
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
...
...
@@ -228,7 +227,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- dump native code
dumpIfSet_dyn dflags
Opt_D_dump_asm "Asm code"
(vcat $ map (
docToSDoc .
pprNatCmmDecl ncgImpl platform) $ concat native)
(vcat $ map (pprNatCmmDecl ncgImpl platform) $ concat native)
-- dump global NCG stats for graph coloring allocator
(case concat $ catMaybes colorStats of
...
...
@@ -261,6 +260,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- write out the imports
Pretty.printDoc Pretty.LeftMode h
$ withPprStyleDoc (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
return ()
...
...
@@ -301,7 +301,8 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
{-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
$ Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native
$ withPprStyleDoc (mkCodeStyle AsmStyle)
$ vcat $ map (pprNatCmmDecl ncgImpl platform) native
-- carefully evaluate this strictly. Binding it with 'let'
-- and then using 'seq' doesn't work, because the let
...
...
@@ -368,7 +369,7 @@ cmmNativeGen dflags ncgImpl us cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (
docToSDoc .
pprNatCmmDecl ncgImpl platform) native)
(vcat $ map (pprNatCmmDecl ncgImpl platform) native)
-- tag instructions with register liveness information
let (withLiveness, usLive) =
...
...
@@ -406,7 +407,7 @@ cmmNativeGen dflags ncgImpl us cmm count
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (
docToSDoc .
pprNatCmmDecl ncgImpl platform) alloced)
(vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
...
...
@@ -437,7 +438,7 @@ cmmNativeGen dflags ncgImpl us cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (
docToSDoc .
pprNatCmmDecl ncgImpl platform) alloced)
(vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
...
...
@@ -481,7 +482,7 @@ cmmNativeGen dflags ncgImpl us cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (
docToSDoc .
pprNatCmmDecl ncgImpl platform) expanded)
(vcat $ map (pprNatCmmDecl ncgImpl platform) expanded)
return ( usAlloc
, expanded
...
...
@@ -498,17 +499,17 @@ x86fp_kludge (CmmProc info lbl (ListGraph code)) =
-- | Build a doc for all the imports.
--
makeImportsDoc :: DynFlags -> [CLabel] ->
Pretty.
Doc
makeImportsDoc :: DynFlags -> [CLabel] ->
S
Doc
makeImportsDoc dflags imports
= dyld_stubs imports
Pretty.
$$
$$
-- On recent versions of Darwin, the linker supports
-- dead-stripping of code and data on a per-symbol basis.
-- There's a hack to make this work in PprMach.pprNatCmmDecl.
(if platformHasSubsectionsViaSymbols (targetPlatform dflags)
then
Pretty.
text ".subsections_via_symbols"
else
Pretty.
empty)
Pretty.
$$
then text ".subsections_via_symbols"
else empty)
$$
-- On recent GNU ELF systems one can mark an object file
-- as not requiring an executable stack. If all objects
-- linked into a program have this note then the program
...
...
@@ -516,23 +517,21 @@ makeImportsDoc dflags imports
-- security. GHC generated code does not need an executable
-- stack so add the note in:
(if platformHasGnuNonexecStack (targetPlatform dflags)
then
Pretty.
text ".section .note.GNU-stack,\"\",@progbits"
else
Pretty.
empty)
Pretty.
$$
then text ".section .note.GNU-stack,\"\",@progbits"
else empty)
$$
-- And just because every other compiler does, lets stick in
-- an identifier directive: .ident "GHC x.y.z"
(if platformHasIdentDirective (targetPlatform dflags)
then let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
else Pretty.empty)
then let compilerIdent = text "GHC" <+> text cProjectVersion
in text ".ident" <+> doubleQuotes compilerIdent
else empty)
where
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
dyld_stubs :: [CLabel] ->
Pretty.
Doc
{- dyld_stubs imps =
Pretty.
vcat $ map pprDyldSymbolStub $
dyld_stubs :: [CLabel] ->
S
Doc
{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $
map head $ group $ sort imps-}
platform = targetPlatform dflags
...
...
@@ -543,7 +542,7 @@ makeImportsDoc dflags imports
-- different uniques; so we compare their text versions...
dyld_stubs imps
| needImportedSymbols arch os
=
Pretty.
vcat $
= vcat $
(pprGotDeclaration arch os :) $
map ( pprImportedSymbol platform . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
...
...
@@ -551,7 +550,7 @@ makeImportsDoc dflags imports
map doPpr $
imps
| otherwise
=
Pretty.
empty
= empty
doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
astyle = mkCodeStyle AsmStyle
...
...
compiler/nativeGen/PIC.hs
View file @
a12b6bf8
...
...
@@ -77,10 +77,8 @@ import CLabel ( mkForeignLabel )
import
StaticFlags
(
opt_PIC
,
opt_Static
)
import
BasicTypes
import
Pretty
import
qualified
Outputable
import
Outputable
import
Panic
(
panic
)
import
DynFlags
import
FastString
...
...
@@ -421,19 +419,6 @@ picRelative _ _ _
--------------------------------------------------------------------------------
-- utility function for pretty-printing asm-labels,
-- copied from PprMach
--
asmSDoc
::
Outputable
.
SDoc
->
Doc
asmSDoc
d
=
Outputable
.
withPprStyleDoc
(
Outputable
.
mkCodeStyle
Outputable
.
AsmStyle
)
d
pprCLabel_asm
::
Platform
->
CLabel
->
Doc
pprCLabel_asm
platform
l
=
asmSDoc
(
pprCLabel
platform
l
)
needImportedSymbols
::
Arch
->
OS
->
Bool
needImportedSymbols
arch
os
|
os
==
OSDarwin
...
...
@@ -468,7 +453,7 @@ gotLabel
--------------------------------------------------------------------------------
-- We don't need to declare any offset tables.
-- However, for PIC on x86, we need a small helper function.
pprGotDeclaration
::
Arch
->
OS
->
Doc
pprGotDeclaration
::
Arch
->
OS
->
S
Doc
pprGotDeclaration
ArchX86
OSDarwin
|
opt_PIC
=
vcat
[
...
...
@@ -480,7 +465,7 @@ pprGotDeclaration ArchX86 OSDarwin
ptext
(
sLit
"
\t
ret"
)
]
pprGotDeclaration
_
OSDarwin
=
Pretty
.
empty
=
empty
-- pprGotDeclaration
-- Output whatever needs to be output once per .s file.
...
...
@@ -491,7 +476,7 @@ pprGotDeclaration arch os
|
osElfTarget
os
,
arch
/=
ArchPPC_64
,
not
opt_PIC
=
Pretty
.
empty
=
empty
|
osElfTarget
os
,
arch
/=
ArchPPC_64
...
...
@@ -511,21 +496,21 @@ pprGotDeclaration _ _
-- Whenever you change something in this assembler output, make sure
-- the splitter in driver/split/ghc-split.lprl recognizes the new output
pprImportedSymbol
::
Platform
->
CLabel
->
Doc
pprImportedSymbol
::
Platform
->
CLabel
->
S
Doc
pprImportedSymbol
platform
@
(
Platform
{
platformArch
=
ArchPPC
,
platformOS
=
OSDarwin
})
importedLbl
|
Just
(
CodeStub
,
lbl
)
<-
dynamicLinkerLabelInfo
importedLbl
=
case
opt_PIC
of
False
->
vcat
[
ptext
(
sLit
".symbol_stub"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"
\t
lis r11,ha16(L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
lis r11,ha16(L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr)"
),
ptext
(
sLit
"
\t
lwz r12,lo16(L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"
\t
lwz r12,lo16(L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr)(r11)"
),
ptext
(
sLit
"
\t
mtctr r12"
),
ptext
(
sLit
"
\t
addi r11,r11,lo16(L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"
\t
addi r11,r11,lo16(L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr)"
),
ptext
(
sLit
"
\t
bctr"
)
]
...
...
@@ -534,32 +519,32 @@ pprImportedSymbol platform@(Platform { platformArch = ArchPPC, platformOS = OSDa
ptext
(
sLit
".section __TEXT,__picsymbolstub1,"
)
<>
ptext
(
sLit
"symbol_stubs,pure_instructions,32"
),
ptext
(
sLit
"
\t
.align 2"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
mflr r0"
),
ptext
(
sLit
"
\t
bcl 20,31,L0$"
)
<>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"L0$"
)
<>
pprCLabel
_asm
platform
lbl
<>
char
':'
,
ptext
(
sLit
"
\t
bcl 20,31,L0$"
)
<>
pprCLabel
platform
lbl
,
ptext
(
sLit
"L0$"
)
<>
pprCLabel
platform
lbl
<>
char
':'
,
ptext
(
sLit
"
\t
mflr r11"
),
ptext
(
sLit
"
\t
addis r11,r11,ha16(L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr-L0$"
)
<>
pprCLabel
_asm
platform
lbl
<>
char
')'
,
ptext
(
sLit
"
\t
addis r11,r11,ha16(L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr-L0$"
)
<>
pprCLabel
platform
lbl
<>
char
')'
,
ptext
(
sLit
"
\t
mtlr r0"
),
ptext
(
sLit
"
\t
lwzu r12,lo16(L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr-L0$"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"
\t
lwzu r12,lo16(L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr-L0$"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
")(r11)"
),
ptext
(
sLit
"
\t
mtctr r12"
),
ptext
(
sLit
"
\t
bctr"
)
]
$+$
vcat
[
ptext
(
sLit
".lazy_symbol_pointer"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
.long dyld_stub_binding_helper"
)]
|
Just
(
SymbolPtr
,
lbl
)
<-
dynamicLinkerLabelInfo
importedLbl
=
vcat
[
ptext
(
sLit
".non_lazy_symbol_pointer"
),
char
'L'
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$non_lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
char
'L'
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$non_lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
.long
\t
0"
)]
|
otherwise
...
...
@@ -572,13 +557,13 @@ pprImportedSymbol platform@(Platform { platformArch = ArchX86, platformOS = OSDa
False
->
vcat
[
ptext
(
sLit
".symbol_stub"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"
\t
jmp *L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
jmp *L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub_binder:"
),
ptext
(
sLit
"
\t
pushl $L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"
\t
pushl $L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr"
),
ptext
(
sLit
"
\t
jmp dyld_stub_binding_helper"
)
]
...
...
@@ -586,16 +571,16 @@ pprImportedSymbol platform@(Platform { platformArch = ArchX86, platformOS = OSDa
vcat
[
ptext
(
sLit
".section __TEXT,__picsymbolstub2,"
)
<>
ptext
(
sLit
"symbol_stubs,pure_instructions,25"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
call ___i686.get_pc_thunk.ax"
),
ptext
(
sLit
"1:"
),
ptext
(
sLit
"
\t
movl L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"
\t
movl L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr-1b(%eax),%edx"
),
ptext
(
sLit
"
\t
jmp *%edx"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub_binder:"
),
ptext
(
sLit
"
\t
lea L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"
\t
lea L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr-1b(%eax),%eax"
),
ptext
(
sLit
"
\t
pushl %eax"
),
ptext
(
sLit
"
\t
jmp dyld_stub_binding_helper"
)
...
...
@@ -603,16 +588,16 @@ pprImportedSymbol platform@(Platform { platformArch = ArchX86, platformOS = OSDa
$+$
vcat
[
ptext
(
sLit
".section __DATA, __la_sym_ptr"
)
<>
(
if
opt_PIC
then
int
2
else
int
3
)
<>
ptext
(
sLit
",lazy_symbol_pointers"
),
ptext
(
sLit
"L"
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
ptext
(
sLit
"
\t
.long L"
)
<>
pprCLabel
_asm
platform
lbl
ptext
(
sLit
"L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
.long L"
)
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$stub_binder"
)]
|
Just
(
SymbolPtr
,
lbl
)
<-
dynamicLinkerLabelInfo
importedLbl
=
vcat
[
ptext
(
sLit
".non_lazy_symbol_pointer"
),
char
'L'
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
"$non_lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
_asm
platform
lbl
,
char
'L'
<>
pprCLabel
platform
lbl
<>
ptext
(
sLit
"$non_lazy_ptr:"
),
ptext
(
sLit
"
\t
.indirect_symbol"
)
<+>
pprCLabel
platform
lbl
,
ptext
(
sLit
"
\t
.long
\t
0"
)]
|
otherwise
...
...
@@ -667,8 +652,8 @@ pprImportedSymbol platform importedLbl
in
vcat
[
ptext
(
sLit
".section
\"
.got2
\"
,
\"
aw
\"
"
),
ptext
(
sLit
".LC_"
)
<>
pprCLabel
_asm
platform
lbl
<>
char
':'
,
ptext
symbolSize
<+>
pprCLabel
_asm
platform
lbl
]
ptext
(
sLit
".LC_"
)
<>
pprCLabel
platform
lbl
<>
char
':'
,
ptext
symbolSize
<+>
pprCLabel
platform
lbl
]
-- PLT code stubs are generated automatically by the dynamic linker.
_
->
empty
...
...
compiler/nativeGen/PPC/Ppr.hs
View file @
a12b6bf8
...
...
@@ -35,10 +35,8 @@ import CLabel
import
Unique
(
pprUnique
,
Uniquable
(
..
)
)
import
Platform
import
Pretty
import
FastString
import
qualified
Outputable
import
Outputable
(
PlatformOutputable
,
panic
)
import
Outputable
import
Data.Word
import
Data.Bits
...
...
@@ -47,7 +45,7 @@ import Data.Bits
-- -----------------------------------------------------------------------------
-- Printing this stuff out
pprNatCmmDecl
::
Platform
->
NatCmmDecl
CmmStatics
Instr
->
Doc
pprNatCmmDecl
::
Platform
->
NatCmmDecl
CmmStatics
Instr
->
S
Doc
pprNatCmmDecl
platform
(
CmmData
section
dats
)
=
pprSectionHeader
platform
section
$$
pprDatas
platform
dats
...
...
@@ -65,7 +63,7 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG
pprSectionHeader
platform
Text
$$
(
(
if
platformHasSubsectionsViaSymbols
platform
then
pprCLabel
_asm
platform
(
mkDeadStripPreventer
info_lbl
)
<>
char
':'
then
pprCLabel
platform
(
mkDeadStripPreventer
info_lbl
)
<>
char
':'
else
empty
)
$$
vcat
(
map
(
pprData
platform
)
info
)
$$
pprLabel
platform
info_lbl
...
...
@@ -82,23 +80,23 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG
-- so that the linker will not think it is unreferenced and dead-strip
-- it. That's why the label is called a DeadStripPreventer (_dsp).
text
"
\t
.long "
<+>
pprCLabel
_asm
platform
info_lbl
<+>
pprCLabel
platform
info_lbl
<+>
char
'-'
<+>
pprCLabel
_asm
platform
(
mkDeadStripPreventer
info_lbl
)
<+>
pprCLabel
platform
(
mkDeadStripPreventer
info_lbl
)
else
empty
)
pprBasicBlock
::
Platform
->
NatBasicBlock
Instr
->
Doc
pprBasicBlock
::
Platform
->
NatBasicBlock
Instr
->
S
Doc
pprBasicBlock
platform
(
BasicBlock
blockid
instrs
)
=
pprLabel
platform
(
mkAsmTempLabel
(
getUnique
blockid
))
$$
vcat
(
map
(
pprInstr
platform
)
instrs
)
pprDatas
::
Platform
->
CmmStatics
->
Doc
pprDatas
::
Platform
->
CmmStatics
->
S
Doc
pprDatas
platform
(
Statics
lbl
dats
)
=
vcat
(
pprLabel
platform
lbl
:
map
(
pprData
platform
)
dats
)
pprData
::
Platform
->
CmmStatic
->
Doc
pprData
::
Platform
->
CmmStatic
->
S
Doc
pprData
_
(
CmmString
str
)
=
pprASCII
str
pprData
platform
(
CmmUninitialised
bytes
)
=
ptext
(
sLit
keyword
)
<>
int
bytes
where
keyword
=
case
platformOS
platform
of
...
...
@@ -106,30 +104,30 @@ pprData platform (CmmUninitialised bytes) = ptext (sLit keyword) <> int bytes
_
->
".skip "
pprData
platform
(
CmmStaticLit
lit
)
=
pprDataItem
platform
lit
pprGloblDecl
::
Platform
->
CLabel
->
Doc
pprGloblDecl
::
Platform
->
CLabel
->
S
Doc
pprGloblDecl
platform
lbl
|
not
(
externallyVisibleCLabel
lbl
)
=
empty
|
otherwise
=
ptext
(
sLit
".globl "
)
<>
pprCLabel
_asm
platform
lbl
|
otherwise
=
ptext
(
sLit
".globl "
)
<>
pprCLabel
platform
lbl
pprTypeAndSizeDecl
::
Platform
->
CLabel
->
Doc
pprTypeAndSizeDecl
::
Platform
->
CLabel
->
S
Doc
pprTypeAndSizeDecl
platform
lbl
|
platformOS
platform
==
OSLinux
&&
externallyVisibleCLabel
lbl
=
ptext
(
sLit
".type "
)
<>
pprCLabel
_asm
platform
lbl
<>
ptext
(
sLit
", @object"
)
pprCLabel
platform
lbl
<>
ptext
(
sLit
", @object"
)
pprTypeAndSizeDecl
_
_
=
empty
pprLabel
::
Platform
->
CLabel
->
Doc
pprLabel
::
Platform
->
CLabel
->
S
Doc
pprLabel
platform
lbl
=
pprGloblDecl
platform
lbl
$$
pprTypeAndSizeDecl
platform
lbl
$$
(
pprCLabel
_asm
platform
lbl
<>
char
':'
)
$$
(
pprCLabel
platform
lbl
<>
char
':'
)
pprASCII
::
[
Word8
]
->
Doc
pprASCII
::
[
Word8
]
->
S
Doc
pprASCII
str
=
vcat
(
map
do1
str
)
$$
do1
0
where
do1
::
Word8
->
Doc
do1
::
Word8
->
S
Doc
do1
w
=
ptext
(
sLit
"
\t
.byte
\t
"
)
<>
int
(
fromIntegral
w
)
...
...
@@ -137,22 +135,22 @@ pprASCII str
-- pprInstr: print an 'Instr'
instance
PlatformOutputable
Instr
where
pprPlatform
platform
instr
=
Outputable
.
docToSDoc
$
pprInstr
platform
instr
pprPlatform
platform
instr
=
pprInstr
platform
instr
pprReg
::
Platform
->
Reg
->
Doc
pprReg
::
Platform
->
Reg
->
S
Doc
pprReg
platform
r
=
case
r
of
RegReal
(
RealRegSingle
i
)
->
ppr_reg_no
i
RegReal
(
RealRegPair
{})
->
panic
"PPC.pprReg: no reg pairs on this arch"
RegVirtual
(
VirtualRegI
u
)
->
text
"%vI_"
<>
asmSDoc
(
pprUnique
u
)
RegVirtual
(
VirtualRegHi
u
)
->
text
"%vHi_"
<>
asmSDoc
(
pprUnique
u
)
RegVirtual
(
VirtualRegF
u
)
->
text
"%vF_"
<>
asmSDoc
(
pprUnique
u
)
RegVirtual
(
VirtualRegD
u
)
->
text
"%vD_"
<>
asmSDoc
(
pprUnique
u
)
RegVirtual
(
VirtualRegSSE
u
)
->
text
"%vSSE_"
<>
asmSDoc
(
pprUnique
u
)
RegVirtual
(
VirtualRegI
u
)
->
text
"%vI_"
<>
pprUnique
u
RegVirtual
(
VirtualRegHi
u
)
->
text
"%vHi_"
<>
pprUnique
u
RegVirtual
(
VirtualRegF
u
)
->
text
"%vF_"
<>
pprUnique
u
RegVirtual
(
VirtualRegD
u
)
->
text
"%vD_"
<>
pprUnique
u
RegVirtual
(
VirtualRegSSE
u
)
->
text
"%vSSE_"
<>
pprUnique
u
where
ppr_reg_no
::
Int
->
Doc
ppr_reg_no
::
Int
->
S
Doc
ppr_reg_no
i
=
case
platformOS
platform
of
OSDarwin
->
...
...
@@ -199,7 +197,7 @@ pprReg platform r
pprSize
::
Size
->
Doc
pprSize
::
Size
->
S
Doc
pprSize
x
=
ptext
(
case
x
of
II8
->
sLit
"b"
...
...
@@ -210,7 +208,7 @@ pprSize x
_
->
panic
"PPC.Ppr.pprSize: no match"
)
pprCond
::
Cond
->
Doc
pprCond
::
Cond
->
S
Doc
pprCond
c
=
ptext
(
case
c
of
{
ALWAYS
->
sLit
""
;
...
...
@@ -221,12 +219,12 @@ pprCond c
GU
->
sLit
"gt"
;
LEU
->
sLit
"le"
;
})
pprImm
::
Platform
->
Imm
->
Doc
pprImm
::
Platform
->
Imm
->
S
Doc
pprImm
_
(
ImmInt
i
)
=
int
i
pprImm
_
(
ImmInteger
i
)
=
integer
i
pprImm
platform
(
ImmCLbl
l
)
=
pprCLabel
_asm
platform
l
pprImm
platform
(
ImmIndex
l
i
)
=
pprCLabel
_asm
platform
l
<>
char
'+'
<>
int
i
pprImm
platform
(
ImmCLbl
l
)
=
pprCLabel
platform
l
pprImm
platform
(
ImmIndex
l
i
)
=
pprCLabel
platform
l
<>
char
'+'
<>
int
i
pprImm
_
(
ImmLit
s
)
=
s
pprImm
_
(
ImmFloat
_
)
=
ptext
(
sLit
"naughty float immediate"
)
...
...
@@ -252,7 +250,7 @@ pprImm platform (HA i)
else
pprImm
platform
i
<>
text
"@ha"
pprAddr
::
Platform
->
AddrMode
->
Doc
pprAddr
::
Platform
->
AddrMode
->
S
Doc
pprAddr
platform
(
AddrRegReg
r1
r2
)
=
pprReg
platform
r1
<+>
ptext
(
sLit
", "
)
<+>
pprReg
platform
r2
...
...
@@ -261,7 +259,7 @@ pprAddr platform (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pp
pprAddr
platform
(
AddrRegImm
r1
imm
)
=
hcat
[
pprImm
platform
imm
,
char
'('
,
pprReg
platform
r1
,
char
')'
]
pprSectionHeader
::
Platform
->
Section
->
Doc
pprSectionHeader
::
Platform
->
Section
->
S
Doc
pprSectionHeader
platform
seg
=
case
seg
of
Text
->
ptext
(
sLit
".text
\n
.align 2"
)
...
...
@@ -283,7 +281,7 @@ pprSectionHeader platform seg
where
osDarwin
=
platformOS
platform
==
OSDarwin
pprDataItem
::
Platform
->
CmmLit
->
Doc
pprDataItem
::
Platform
->
CmmLit
->
S
Doc
pprDataItem
platform
lit
=
vcat
(
ppr_item
(
cmmTypeSize
$
cmmLitType
lit
)
lit
)
where
...
...
@@ -314,7 +312,7 @@ pprDataItem platform lit
=
panic
"PPC.Ppr.pprDataItem: no match"
pprInstr
::
Platform
->
Instr
->
Doc
pprInstr
::
Platform
->
Instr
->
S
Doc
pprInstr
_
(
COMMENT
_
)
=
empty
-- nuke 'em
{-
...
...
@@ -473,7 +471,7 @@ pprInstr platform (BCC cond blockid) = hcat [
ptext
(
sLit
"b"
),
pprCond
cond
,
char
'
\t
'
,
pprCLabel
_asm
platform
lbl
pprCLabel
platform
lbl
]
where
lbl
=
mkAsmTempLabel
(
getUnique
blockid
)
...
...
@@ -485,7 +483,7 @@ pprInstr platform (BCCFAR cond blockid) = vcat [
],
hcat
[
ptext
(
sLit
"
\t
b
\t
"
),
pprCLabel
_asm
platform
lbl
pprCLabel
platform
lbl
]
]
where
lbl
=
mkAsmTempLabel
(
getUnique
blockid
)
...
...
@@ -494,7 +492,7 @@ pprInstr platform (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
char
'
\t
'
,
ptext
(
sLit
"b"
),
char
'
\t
'
,
pprCLabel
_asm
platform
lbl
pprCLabel
platform
lbl
]
pprInstr
platform
(
MTCTR
reg
)
=
hcat
[
...
...
@@ -509,7 +507,7 @@ pprInstr _ (BCTR _ _) = hcat [
]
pprInstr
platform
(
BL
lbl
_
)
=
hcat
[
ptext
(
sLit
"
\t
bl
\t
"
),
pprCLabel
_asm
platform
lbl
pprCLabel
platform
lbl
]
pprInstr
_
(
BCTRL
_
)
=
hcat
[
char
'
\t
'
,
...
...
@@ -663,7 +661,7 @@ pprInstr _ LWSYNC = ptext (sLit "\tlwsync")
-- pprInstr _ _ = panic "pprInstr (ppc)"
pprLogic
::
Platform
->
LitString
->
Reg
->
Reg
->
RI
->
Doc
pprLogic
::
Platform
->
LitString
->
Reg
->
Reg
->
RI
->
S
Doc
pprLogic
platform
op
reg1
reg2
ri
=
hcat
[
char
'
\t
'
,
ptext
op
,
...
...
@@ -679,7 +677,7 @@ pprLogic platform op reg1 reg2 ri = hcat [
]
pprUnary
::
Platform
->
LitString
->
Reg
->
Reg
->
Doc
pprUnary
::
Platform
->
LitString
->
Reg
->
Reg
->
S
Doc
pprUnary
platform
op
reg1
reg2
=
hcat
[
char
'
\t
'
,
ptext
op
,
...
...
@@ -690,7 +688,7 @@ pprUnary platform op reg1 reg2 = hcat [
]
pprBinaryF
::
Platform
->
LitString
->
Size
->
Reg
->
Reg
->
Reg
->
Doc
pprBinaryF
::
Platform
->
LitString
->
Size
->
Reg
->
Reg
->
Reg
->
S
Doc
pprBinaryF
platform
op
sz
reg1
reg2
reg3
=
hcat
[
char
'
\t
'
,
ptext
op
,
...
...
@@ -703,12 +701,12 @@ pprBinaryF platform op sz reg1 reg2 reg3 = hcat [
pprReg
platform
reg3
]
pprRI
::
Platform
->
RI
->
Doc
pprRI
::
Platform
->
RI
->
S
Doc
pprRI
platform
(
RIReg
r
)
=
pprReg
platform
r
pprRI
platform
(
RIImm
r
)
=
pprImm
platform
r
pprFSize
::
Size
->
Doc