LlvmMangler.hs 5.3 KB
Newer Older
dterei's avatar
dterei committed
1
{-# OPTIONS -fno-warn-unused-binds #-}
2
3
-- -----------------------------------------------------------------------------
-- | GHC LLVM Mangler
4
--
5
-- This script processes the assembly produced by LLVM, rearranging the code
dterei's avatar
dterei committed
6
-- so that an info table appears before its corresponding function.
7
--
dterei's avatar
dterei committed
8
9
10
-- On OSX we also use it to fix up the stack alignment, which needs to be 16
-- byte aligned but always ends up off by word bytes because GHC sets it to
-- the 'wrong' starting value in the RTS.
11
12
--

13
14
module LlvmMangler ( llvmFixupAsm ) where

15
16
#include "HsVersions.h"

17
18
import DynFlags ( DynFlags )
import ErrUtils ( showPass )
dterei's avatar
dterei committed
19
20
import LlvmCodeGen.Ppr ( infoSection )

21
import Control.Exception
22
import Control.Monad ( when )
23
import qualified Data.ByteString.Char8 as B
benl's avatar
benl committed
24
import Data.Char
25
26
import System.IO

27
28
29
import Data.List ( sortBy )
import Data.Function ( on )

30
-- Magic Strings
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
31
secStmt, infoSec, newLine, spInst, jmpInst, textStmt, dataStmt, syntaxUnified :: B.ByteString
dterei's avatar
dterei committed
32
33
secStmt    = B.pack "\t.section\t"
infoSec    = B.pack infoSection
34
newLine    = B.pack "\n"
35
jmpInst    = B.pack "\n\tjmp"
36
37
textStmt   = B.pack "\t.text"
dataStmt   = B.pack "\t.data"
38
syntaxUnified = B.pack "\t.syntax unified"
39

40
41
infoLen, labelStart, spFix :: Int
infoLen    = B.length infoSec
42
labelStart = B.length jmpInst
43

44
45
46
47
48
49
50
51
#if x86_64_TARGET_ARCH
spInst     = B.pack ", %rsp\n"
spFix      = 8
#else
spInst     = B.pack ", %esp\n"
spFix      = 4
#endif

52
-- Search Predicates
53
eolPred, dollarPred, commaPred :: Char -> Bool
54
eolPred    = ((==) '\n')
55
dollarPred = ((==) '$')
56
commaPred  = ((==) ',')
57
58

-- | Read in assembly file and process
59
60
61
llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm dflags f1 f2 = do
    showPass dflags "LlVM Mangler"
62
63
    r <- openBinaryFile f1 ReadMode
    w <- openBinaryFile f2 WriteMode
64
    ss <- readSections r w
65
    hClose r
66
67
    let fixed = fixTables ss
    mapM_ (writeSection w) fixed
68
    hClose w
69
70
    return ()

71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
type Section = (B.ByteString, B.ByteString)

-- | Splits the file contents into its sections. Each is returned as a
-- pair of the form (header line, contents lines)
readSections :: Handle -> Handle -> IO [Section]
readSections r w = go B.empty [] []
  where
    go hdr ss ls = do
      e_l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)

      -- Note that ".type" directives at the end of a section refer to
      -- the first directive of the *next* section, therefore we take
      -- it over to that section.
      let (tys, ls') = span isType ls
          isType = B.isPrefixOf (B.pack "\t.type")
          cts = B.intercalate newLine $ reverse ls'

      -- Decide whether to directly output the section or append it
      -- to the list for resorting.
      let finishSection
            | infoSec `B.isInfixOf` hdr =
                cts `seq` return $ (hdr, cts):ss
            | otherwise =
94
                writeSection w (hdr, cts) >> return ss
95
96

      case e_l of
97
98
99
100
        Right l | l == syntaxUnified 
                  -> finishSection >>= \ss' -> writeSection w (l, B.empty)
                                   >> go B.empty ss' tys
                | any (`B.isPrefixOf` l) [secStmt, textStmt, dataStmt]
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
                  -> finishSection >>= \ss' -> go l ss' tys
                | otherwise
                  -> go hdr ss (l:ls)
        Left _    -> finishSection >>= \ss' -> return (reverse ss')

-- | Writes sections back
writeSection :: Handle -> Section -> IO ()
writeSection w (hdr, cts) = do
  when (not $ B.null hdr) $
    B.hPutStrLn w hdr
  B.hPutStrLn w cts

-- | Reorder and convert sections so info tables end up next to the
-- code. Also does stack fixups.
fixTables :: [Section] -> [Section]
116
fixTables ss = map strip sorted
117
118
119
120
121
122
123
124
125
  where
    -- Resort sections: We only assign a non-zero number to all
    -- sections having the "STRIP ME" marker. As sortBy is stable,
    -- this will cause all these sections to be appended to the end of
    -- the file in the order given by the indexes.
    extractIx hdr
      | B.null a  = 0
      | otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a)
      where (_,a) = B.breakSubstring infoSec hdr
126

127
    indexed = zip (map (extractIx . fst) ss) ss
128

129
130
131
132
133
134
135
136
    sorted = map snd $ sortBy (compare `on` fst) indexed

    -- Turn all the "STRIP ME" sections into normal text sections, as
    -- they are in the right place now.
    strip (hdr, cts)
      | infoSec `B.isInfixOf` hdr = (textStmt, cts)
      | otherwise                 = (hdr, cts)
 
137
138
139
140
{-|
    Mac OS X requires that the stack be 16 byte aligned when making a function
    call (only really required though when making a call that will pass through
    the dynamic linker). The alignment isn't correctly generated by LLVM as
dterei's avatar
dterei committed
141
    LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry
142
143
144
145
    (since the function call was 16 byte aligned and the return address should
    have been pushed, so sub 4). GHC though since it always uses jumps keeps
    the stack 16 byte aligned on both function calls and function entry.

146
147
148
    We correct the alignment here for Mac OS X i386. The x86_64 target already
    has the correct alignment since we keep the stack 16+8 aligned throughout
    STG land for 64-bit targets.
149
150
-}

dterei's avatar
dterei committed
151
-- | Read an int or error
152
153
readInt :: B.ByteString -> Int
readInt str | B.all isDigit str = (read . B.unpack) str
dterei's avatar
dterei committed
154
155
            | otherwise = error $ "LLvmMangler Cannot read " ++ show str
                                ++ " as it's not an Int"
benl's avatar
benl committed
156