1 {-# OPTIONS -fno-warn-unused-binds #-}
2 -- -----------------------------------------------------------------------------
5 -- This script processes the assembly produced by LLVM, rearranging the code
6 -- so that an info table appears before its corresponding function.
8 -- On OSX we also use it to fix up the stack alignment, which needs to be 16
9 -- byte aligned but always ends up off by word bytes because GHC sets it to
10 -- the 'wrong' starting value in the RTS.
13 module LlvmMangler ( llvmFixupAsm ) where
15 #include "HsVersions.h"
17 import LlvmCodeGen.Ppr ( infoSection )
19 import Control.Exception
20 import qualified Data.ByteString.Char8 as B
22 import qualified Data.IntMap as I
26 secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
27 secStmt = B.pack "\t.section\t"
28 infoSec = B.pack infoSection
29 newInfoSec = B.pack "\n\t.text"
31 jmpInst = B.pack "\n\tjmp"
33 infoLen, labelStart, spFix :: Int
34 infoLen = B.length infoSec
35 labelStart = B.length jmpInst
37 #if x86_64_TARGET_ARCH
38 spInst = B.pack ", %rsp\n"
41 spInst = B.pack ", %esp\n"
46 eolPred, dollarPred, commaPred :: Char -> Bool
48 dollarPred = ((==) '$')
49 commaPred = ((==) ',')
51 -- | Read in assembly file and process
52 llvmFixupAsm :: FilePath -> FilePath -> IO ()
53 llvmFixupAsm f1 f2 = do
54 r <- openBinaryFile f1 ReadMode
55 w <- openBinaryFile f2 WriteMode
57 B.hPut w (B.pack "\n\n")
63 Here we process the assembly file one function and data
64 definition at a time. When a function is encountered that
65 should have a info table we store it in a map. Otherwise
66 we print it. When an info table is found we retrieve its
67 function from the map and print them both.
69 For all functions we fix up the stack alignment. We also
70 fix up the section definition for functions and info tables.
72 fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
77 else let fun = fixupStack f B.empty
78 (a,b) = B.breakSubstring infoSec fun
79 (a',s) = B.breakEnd eolPred a
80 -- We search for the section header in two parts as it makes
81 -- us portable across OS types and LLVM version types since
82 -- section names are wrapped differently.
83 secHdr = secStmt `B.isPrefixOf` s
84 (x,c) = B.break eolPred b
85 fun' = a' `B.append` newInfoSec `B.append` c
86 n = readInt $ B.takeWhile isDigit $ B.drop infoLen x
87 (bs, m') | B.null b || not secHdr = ([fun], m)
88 | even n = ([], I.insert n fun' m)
89 | otherwise = case I.lookup (n+1) m of
90 Just xf' -> ([fun',xf'], m)
91 Nothing -> ([fun'], m)
92 in mapM_ (B.hPut w) bs >> fixTables r w m'
94 -- | Read in the next function/data defenition
95 getFun :: Handle -> B.ByteString -> IO B.ByteString
97 l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
99 Right l' | B.null l' -> return f
100 | otherwise -> getFun r (f `B.append` newLine `B.append` l')
101 Left _ -> return B.empty
104 Mac OS X requires that the stack be 16 byte aligned when making a function
105 call (only really required though when making a call that will pass through
106 the dynamic linker). The alignment isn't correctly generated by LLVM as
107 LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry
108 (since the function call was 16 byte aligned and the return address should
109 have been pushed, so sub 4). GHC though since it always uses jumps keeps
110 the stack 16 byte aligned on both function calls and function entry.
112 We correct the alignment here.
114 fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
116 #if !darwin_TARGET_OS
120 fixupStack f f' | B.null f' =
122 (a, c) = B.breakSubstring spInst f
123 (b, n) = B.breakEnd dollarPred a
124 num = B.pack $ show $ readInt n + spFix
127 else fixupStack c $ f' `B.append` b `B.append` num
131 (a, c) = B.breakSubstring jmpInst f
132 -- we matched on a '\n' so go past it
133 (l', b) = B.break eolPred $ B.tail c
134 l = (B.head c) `B.cons` l'
135 (a', n) = B.breakEnd dollarPred a
136 (n', x) = B.break commaPred n
137 num = B.pack $ show $ readInt n' + spFix
138 -- We need to avoid processing jumps to labels, they are of the form:
139 -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L...
140 targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $
144 else if B.head targ == 'L'
145 then fixupStack b $ f' `B.append` a `B.append` l
146 else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
150 -- | Read an int or error
151 readInt :: B.ByteString -> Int
152 readInt str | B.all isDigit str = (read . B.unpack) str
153 | otherwise = error $ "LLvmMangler Cannot read " ++ show str
154 ++ " as it's not an Int"