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 "\n\tjmp"
29 infoLen, spFix, labelStart :: Int
30 infoLen = B.length infoSec
32 labelStart = B.length jmpInst + 1
35 eolPred, dollarPred, commaPred :: Char -> Bool
37 dollarPred = ((==) '$')
38 commaPred = ((==) ',')
40 -- | Read in assembly file and process
41 llvmFixupAsm :: FilePath -> FilePath -> IO ()
42 llvmFixupAsm f1 f2 = do
43 r <- openBinaryFile f1 ReadMode
44 w <- openBinaryFile f2 WriteMode
46 B.hPut w (B.pack "\n\n")
52 Here we process the assembly file one function and data
53 defenition at a time. When a function is encountered that
54 should have a info table we store it in a map. Otherwise
55 we print it. When an info table is found we retrieve its
56 function from the map and print them both.
58 For all functions we fix up the stack alignment. We also
59 fix up the section defenition for functions and info tables.
61 fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
66 else let fun = fixupStack f B.empty
67 (a,b) = B.breakSubstring infoSec fun
68 (x,c) = B.break eolPred b
69 fun' = a `B.append` newInfoSec `B.append` c
70 n = readInt $ B.drop infoLen x
71 (bs, m') | B.null b = ([fun], m)
72 | even n = ([], I.insert n fun' m)
73 | otherwise = case I.lookup (n+1) m of
74 Just xf' -> ([fun',xf'], m)
75 Nothing -> ([fun'], m)
76 in mapM_ (B.hPut w) bs >> fixTables r w m'
78 -- | Read in the next function/data defenition
79 getFun :: Handle -> B.ByteString -> IO B.ByteString
81 l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
83 Right l' | B.null l' -> return f
84 | otherwise -> getFun r (f `B.append` newLine `B.append` l')
85 Left _ -> return B.empty
88 Mac OS X requires that the stack be 16 byte aligned when making a function
89 call (only really required though when making a call that will pass through
90 the dynamic linker). The alignment isn't correctly generated by LLVM as
91 LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
92 (since the function call was 16 byte aligned and the return address should
93 have been pushed, so sub 4). GHC though since it always uses jumps keeps
94 the stack 16 byte aligned on both function calls and function entry.
96 We correct the alignment here.
98 fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
99 fixupStack f f' | B.null f' =
101 (a, c) = B.breakSubstring spInst f
102 (b, n) = B.breakEnd dollarPred a
103 num = B.pack $ show $ readInt n + spFix
106 else fixupStack c $ f' `B.append` b `B.append` num
110 (a, c) = B.breakSubstring jmpInst f
111 -- we matched on a '\n' so go past it
112 (l', b) = B.break eolPred $ B.tail c
113 l = (B.head c) `B.cons` l'
114 (a', n) = B.breakEnd dollarPred a
115 (n', x) = B.break commaPred n
116 num = B.pack $ show $ readInt n' + spFix
119 -- We need to avoid processing jumps to labels, they are of the form:
120 -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
121 else if B.index c labelStart == 'L'
122 then fixupStack b $ f' `B.append` a `B.append` l
123 else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
126 -- | read an int or error
127 readInt :: B.ByteString -> Int
128 readInt str | B.all isDigit str = (read . B.unpack) str
129 | otherwise = error $ "LLvmMangler Cannot read" ++ show str
130 ++ "as it's not an Int"