PprBase.hs 7.4 KB
Newer Older
1 2 3 4 5 6 7 8 9
-----------------------------------------------------------------------------
--
-- Pretty-printing assembly language
--
-- (c) The University of Glasgow 1993-2005
--
-----------------------------------------------------------------------------

module PprBase (
10 11 12
        castFloatToWord8Array,
        castDoubleToWord8Array,
        floatToBytes,
13
        doubleToBytes,
14
        pprASCII,
15
        pprSectionHeader
16 17 18 19
)

where

20 21
import GhcPrelude

22
import AsmUtils
23 24 25 26 27 28 29
import CLabel
import Cmm
import DynFlags
import FastString
import Outputable
import Platform

30 31
import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST
32

33 34 35
import Control.Monad.ST

import Data.Word
36
import Data.Char
37 38
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
39 40 41 42 43 44 45



-- -----------------------------------------------------------------------------
-- Converting floating-point literals to integrals for printing

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 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
-- target with the opposite endianness, this should work ok
-- on all targets.

-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
-- could they be merged?

floatToBytes :: Float -> [Int]
floatToBytes f
   = runST (do
        arr <- newArray_ ((0::Int),3)
        writeArray arr 0 f
        arr <- castFloatToWord8Array arr
        i0 <- readArray arr 0
        i1 <- readArray arr 1
        i2 <- readArray arr 2
        i3 <- readArray arr 3
        return (map fromIntegral [i0,i1,i2,i3])
     )

doubleToBytes :: Double -> [Int]
doubleToBytes d
   = runST (do
        arr <- newArray_ ((0::Int),7)
        writeArray arr 0 d
        arr <- castDoubleToWord8Array arr
        i0 <- readArray arr 0
        i1 <- readArray arr 1
        i2 <- readArray arr 2
        i3 <- readArray arr 3
        i4 <- readArray arr 4
        i5 <- readArray arr 5
        i6 <- readArray arr 6
        i7 <- readArray arr 7
        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
     )
88

89 90 91 92 93 94
-- ---------------------------------------------------------------------------
-- Printing ASCII strings.
--
-- Print as a string and escape non-printable characters.
-- This is similar to charToC in Utils.

95
pprASCII :: ByteString -> SDoc
96 97 98 99 100
pprASCII str
  -- Transform this given literal bytestring to escaped string and construct
  -- the literal SDoc directly.
  -- See Trac #14741
  -- and Note [Pretty print ASCII when AsmCodeGen]
101
  = text $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" (BS.unpack str)
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
    where
       do1 :: Int -> String
       do1 w | '\t' <- chr w = "\\t"
             | '\n' <- chr w = "\\n"
             | '"'  <- chr w = "\\\""
             | '\\' <- chr w = "\\\\"
             | isPrint (chr w) = [chr w]
             | otherwise = '\\' : octal w

       octal :: Int -> String
       octal w = [ chr (ord '0' + (w `div` 64) `mod` 8)
                 , chr (ord '0' + (w `div` 8) `mod` 8)
                 , chr (ord '0' + w `mod` 8)
                 ]

{-
Note [Pretty print ASCII when AsmCodeGen]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously, when generating assembly code, we created SDoc with
`(ptext . sLit)` for every bytes in literal bytestring, then
combine them using `hcat`.

When handling literal bytestrings with millions of bytes,
millions of SDoc would be created and to combine, leading to
high memory usage.

Now we escape the given bytestring to string directly and construct
SDoc only once. This improvement could dramatically decrease the
memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
string in source code. See Trac #14741 for profiling results.
-}

134 135 136 137 138 139
-- ----------------------------------------------------------------------------
-- 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.
140 141 142 143
--
-- For string literals, additional flags are specified to enable merging of
-- identical strings in the linker. With -split-sections each string also gets
-- a unique section to allow strings from unused code to be GC'd.
144 145 146 147

pprSectionHeader :: Platform -> Section -> SDoc
pprSectionHeader platform (Section t suffix) =
 case platformOS platform of
148 149 150 151
   OSAIX     -> pprXcoffSectionHeader t
   OSDarwin  -> pprDarwinSectionHeader t
   OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix
   _         -> pprGNUSectionHeader (char '.') t suffix
152

153 154
pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc
pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags ->
155
  let splitSections = gopt Opt_SplitSections dflags
156
      subsection | splitSections = sep <> ppr suffix
157
                 | otherwise     = empty
158 159
  in  text ".section " <> ptext (header dflags) <> subsection <>
      flags dflags
160
  where
161
    header dflags = case t of
162 163
      Text -> sLit ".text"
      Data -> sLit ".data"
164 165 166 167 168 169 170 171
      ReadOnlyData  | OSMinGW32 <- platformOS (targetPlatform dflags)
                                -> sLit ".rdata"
                    | otherwise -> sLit ".rodata"
      RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)
                                -- Concept does not exist on Windows,
                                -- So map these to R/O data.
                                          -> sLit ".rdata$rel.ro"
                              | otherwise -> sLit ".data.rel.ro"
172
      UninitialisedData -> sLit ".bss"
173 174 175
      ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags)
                                 -> sLit ".rdata$cst16"
                     | otherwise -> sLit ".rodata.cst16"
176 177
      CString
        | OSMinGW32 <- platformOS (targetPlatform dflags)
178
                    -> sLit ".rdata"
179
        | otherwise -> sLit ".rodata.str"
180 181
      OtherSection _ ->
        panic "PprBase.pprGNUSectionHeader: unknown section type"
182 183 184
    flags dflags = case t of
      CString
        | OSMinGW32 <- platformOS (targetPlatform dflags)
185
                    -> empty
186
        | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1"
187
      _ -> empty
188

189 190 191 192 193 194 195 196 197
-- XCOFF doesn't support relocating label-differences, so we place all
-- RO sections into .text[PR] sections
pprXcoffSectionHeader :: SectionType -> SDoc
pprXcoffSectionHeader t = text $ case t of
     Text                    -> ".csect .text[PR]"
     Data                    -> ".csect .data[RW]"
     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"
     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"
     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"
198
     CString                 -> ".csect .text[PR] # CString"
199 200 201 202
     UninitialisedData       -> ".csect .data[BS]"
     OtherSection _          ->
       panic "PprBase.pprXcoffSectionHeader: unknown section type"

203 204 205 206 207 208 209 210 211
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"
212
     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"
213 214
     OtherSection _ ->
       panic "PprBase.pprDarwinSectionHeader: unknown section type"