1 -- -----------------------------------------------------------------------------
4 -- This script processes the assembly produced by LLVM, rearranging the code
5 -- so that an info table appears before its corresponding function. We also
6 -- use it to fix up the stack alignment, which needs to be 16 byte aligned
7 -- but always ends up off by 4 bytes because GHC sets it to the 'wrong'
8 -- starting value in the RTS.
10 -- We only need this for Mac OS X, other targets don't use it.
13 module LlvmMangler ( llvmFixupAsm ) where
15 import Control.Exception
16 import qualified Data.ByteString.Char8 as B
18 import qualified Data.IntMap as I
22 infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
23 infoSec = B.pack "\t.section\t__STRIP,__me"
24 newInfoSec = B.pack "\n\t.text"
26 spInst = B.pack ", %esp\n"
27 jmpInst = B.pack "jmp"
30 infoLen = B.length infoSec
34 eolPred, dollarPred, commaPred :: Char -> Bool
36 dollarPred = ((==) '$')
37 commaPred = ((==) ',')
39 -- | Read in assembly file and process
40 llvmFixupAsm :: FilePath -> FilePath -> IO ()
41 llvmFixupAsm f1 f2 = do
42 r <- openBinaryFile f1 ReadMode
43 w <- openBinaryFile f2 WriteMode
45 B.hPut w (B.pack "\n\n")
51 Here we process the assembly file one function and data
52 defenition at a time. When a function is encountered that
53 should have a info table we store it in a map. Otherwise
54 we print it. When an info table is found we retrieve its
55 function from the map and print them both.
57 For all functions we fix up the stack alignment. We also
58 fix up the section defenition for functions and info tables.
60 fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
65 else let fun = fixupStack f B.empty
66 (a,b) = B.breakSubstring infoSec fun
67 (x,c) = B.break eolPred b
68 fun' = a `B.append` newInfoSec `B.append` c
69 n = readInt $ B.drop infoLen x
70 (bs, m') | B.null b = ([fun], m)
71 | even n = ([], I.insert n fun' m)
72 | otherwise = case I.lookup (n+1) m of
73 Just xf' -> ([fun',xf'], m)
74 Nothing -> ([fun'], m)
75 in mapM_ (B.hPut w) bs >> fixTables r w m'
77 -- | Read in the next function/data defenition
78 getFun :: Handle -> B.ByteString -> IO B.ByteString
80 l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
82 Right l' | B.null l' -> return f
83 | otherwise -> getFun r (f `B.append` newLine `B.append` l')
84 Left _ -> return B.empty
87 Mac OS X requires that the stack be 16 byte aligned when making a function
88 call (only really required though when making a call that will pass through
89 the dynamic linker). The alignment isn't correctly generated by LLVM as
90 LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
91 (since the function call was 16 byte aligned and the return address should
92 have been pushed, so sub 4). GHC though since it always uses jumps keeps
93 the stack 16 byte aligned on both function calls and function entry.
95 We correct the alignment here.
97 fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
98 fixupStack f f' | B.null f' =
100 (a, c) = B.breakSubstring spInst f
101 (b, n) = B.breakEnd dollarPred a
102 num = B.pack $ show $ readInt n + spFix
105 else fixupStack c $ f' `B.append` b `B.append` num
109 (a, c) = B.breakSubstring jmpInst f
110 (l, b) = B.break eolPred c
111 (a', n) = B.breakEnd dollarPred a
112 (n', x) = B.break commaPred n
113 num = B.pack $ show $ readInt n' + spFix
116 -- We need to avoid processing jumps to labels, they are of the form:
117 -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
118 else if B.index c 4 == 'L'
119 then fixupStack b $ f' `B.append` a `B.append` l
120 else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
123 -- | read an int or error
124 readInt :: B.ByteString -> Int
125 readInt str | B.all isDigit str = (read . B.unpack) str
126 | otherwise = error $ "LLvmMangler Cannot read" ++ show str
127 ++ "as it's not an Int"