4cdcceec9e2e1600408d50657a766363a46d5d70
[ghc.git] / compiler / nativeGen / PprBase.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Pretty-printing assembly language
4 --
5 -- (c) The University of Glasgow 1993-2005
6 --
7 -----------------------------------------------------------------------------
8
9 module PprBase (
10 castFloatToWord8Array,
11 castDoubleToWord8Array,
12 floatToBytes,
13 doubleToBytes,
14 pprASCII,
15 pprSectionHeader
16 )
17
18 where
19
20 import GhcPrelude
21
22 import AsmUtils
23 import CLabel
24 import Cmm
25 import DynFlags
26 import FastString
27 import Outputable
28 import Platform
29
30 import qualified Data.Array.Unsafe as U ( castSTUArray )
31 import Data.Array.ST
32
33 import Control.Monad.ST
34
35 import Data.Word
36 import Data.Char
37 import Data.ByteString (ByteString)
38 import qualified Data.ByteString as BS
39
40
41
42 -- -----------------------------------------------------------------------------
43 -- Converting floating-point literals to integrals for printing
44
45 castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
46 castFloatToWord8Array = U.castSTUArray
47
48 castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
49 castDoubleToWord8Array = U.castSTUArray
50
51 -- floatToBytes and doubleToBytes convert to the host's byte
52 -- order. Providing that we're not cross-compiling for a
53 -- target with the opposite endianness, this should work ok
54 -- on all targets.
55
56 -- ToDo: this stuff is very similar to the shenanigans in PprAbs,
57 -- could they be merged?
58
59 floatToBytes :: Float -> [Int]
60 floatToBytes f
61 = runST (do
62 arr <- newArray_ ((0::Int),3)
63 writeArray arr 0 f
64 arr <- castFloatToWord8Array arr
65 i0 <- readArray arr 0
66 i1 <- readArray arr 1
67 i2 <- readArray arr 2
68 i3 <- readArray arr 3
69 return (map fromIntegral [i0,i1,i2,i3])
70 )
71
72 doubleToBytes :: Double -> [Int]
73 doubleToBytes d
74 = runST (do
75 arr <- newArray_ ((0::Int),7)
76 writeArray arr 0 d
77 arr <- castDoubleToWord8Array arr
78 i0 <- readArray arr 0
79 i1 <- readArray arr 1
80 i2 <- readArray arr 2
81 i3 <- readArray arr 3
82 i4 <- readArray arr 4
83 i5 <- readArray arr 5
84 i6 <- readArray arr 6
85 i7 <- readArray arr 7
86 return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
87 )
88
89 -- ---------------------------------------------------------------------------
90 -- Printing ASCII strings.
91 --
92 -- Print as a string and escape non-printable characters.
93 -- This is similar to charToC in Utils.
94
95 pprASCII :: ByteString -> SDoc
96 pprASCII str
97 -- Transform this given literal bytestring to escaped string and construct
98 -- the literal SDoc directly.
99 -- See Trac #14741
100 -- and Note [Pretty print ASCII when AsmCodeGen]
101 = text $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" (BS.unpack str)
102 where
103 do1 :: Int -> String
104 do1 w | '\t' <- chr w = "\\t"
105 | '\n' <- chr w = "\\n"
106 | '"' <- chr w = "\\\""
107 | '\\' <- chr w = "\\\\"
108 | isPrint (chr w) = [chr w]
109 | otherwise = '\\' : octal w
110
111 octal :: Int -> String
112 octal w = [ chr (ord '0' + (w `div` 64) `mod` 8)
113 , chr (ord '0' + (w `div` 8) `mod` 8)
114 , chr (ord '0' + w `mod` 8)
115 ]
116
117 {-
118 Note [Pretty print ASCII when AsmCodeGen]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
120 Previously, when generating assembly code, we created SDoc with
121 `(ptext . sLit)` for every bytes in literal bytestring, then
122 combine them using `hcat`.
123
124 When handling literal bytestrings with millions of bytes,
125 millions of SDoc would be created and to combine, leading to
126 high memory usage.
127
128 Now we escape the given bytestring to string directly and construct
129 SDoc only once. This improvement could dramatically decrease the
130 memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
131 string in source code. See Trac #14741 for profiling results.
132 -}
133
134 -- ----------------------------------------------------------------------------
135 -- Printing section headers.
136 --
137 -- If -split-section was specified, include the suffix label, otherwise just
138 -- print the section type. For Darwin, where subsections-for-symbols are
139 -- used instead, only print section type.
140 --
141 -- For string literals, additional flags are specified to enable merging of
142 -- identical strings in the linker. With -split-sections each string also gets
143 -- a unique section to allow strings from unused code to be GC'd.
144
145 pprSectionHeader :: Platform -> Section -> SDoc
146 pprSectionHeader platform (Section t suffix) =
147 case platformOS platform of
148 OSAIX -> pprXcoffSectionHeader t
149 OSDarwin -> pprDarwinSectionHeader t
150 OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix
151 _ -> pprGNUSectionHeader (char '.') t suffix
152
153 pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc
154 pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags ->
155 let splitSections = gopt Opt_SplitSections dflags
156 subsection | splitSections = sep <> ppr suffix
157 | otherwise = empty
158 in text ".section " <> ptext (header dflags) <> subsection <>
159 flags dflags
160 where
161 header dflags = case t of
162 Text -> sLit ".text"
163 Data -> sLit ".data"
164 ReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)
165 -> sLit ".rdata"
166 | otherwise -> sLit ".rodata"
167 RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)
168 -- Concept does not exist on Windows,
169 -- So map these to R/O data.
170 -> sLit ".rdata$rel.ro"
171 | otherwise -> sLit ".data.rel.ro"
172 UninitialisedData -> sLit ".bss"
173 ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags)
174 -> sLit ".rdata$cst16"
175 | otherwise -> sLit ".rodata.cst16"
176 CString
177 | OSMinGW32 <- platformOS (targetPlatform dflags)
178 -> sLit ".rdata"
179 | otherwise -> sLit ".rodata.str"
180 OtherSection _ ->
181 panic "PprBase.pprGNUSectionHeader: unknown section type"
182 flags dflags = case t of
183 CString
184 | OSMinGW32 <- platformOS (targetPlatform dflags)
185 -> empty
186 | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1"
187 _ -> empty
188
189 -- XCOFF doesn't support relocating label-differences, so we place all
190 -- RO sections into .text[PR] sections
191 pprXcoffSectionHeader :: SectionType -> SDoc
192 pprXcoffSectionHeader t = text $ case t of
193 Text -> ".csect .text[PR]"
194 Data -> ".csect .data[RW]"
195 ReadOnlyData -> ".csect .text[PR] # ReadOnlyData"
196 RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"
197 ReadOnlyData16 -> ".csect .text[PR] # ReadOnlyData16"
198 CString -> ".csect .text[PR] # CString"
199 UninitialisedData -> ".csect .data[BS]"
200 OtherSection _ ->
201 panic "PprBase.pprXcoffSectionHeader: unknown section type"
202
203 pprDarwinSectionHeader :: SectionType -> SDoc
204 pprDarwinSectionHeader t =
205 ptext $ case t of
206 Text -> sLit ".text"
207 Data -> sLit ".data"
208 ReadOnlyData -> sLit ".const"
209 RelocatableReadOnlyData -> sLit ".const_data"
210 UninitialisedData -> sLit ".data"
211 ReadOnlyData16 -> sLit ".const"
212 CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"
213 OtherSection _ ->
214 panic "PprBase.pprDarwinSectionHeader: unknown section type"