5f74dc4564fd992a90878f423bdcaf9b9907cf63
[ghc.git] / compiler / llvmGen / LlvmMangler.hs
1 -- -----------------------------------------------------------------------------
2 -- | GHC LLVM Mangler
3 --
4 -- This script processes the assembly produced by LLVM, rearranging the code
5 -- so that an info table appears before its corresponding function.
6 --
7
8 module LlvmMangler ( llvmFixupAsm ) where
9
10 import DynFlags ( DynFlags )
11 import ErrUtils ( showPass )
12 import LlvmCodeGen.Ppr ( infoSection )
13
14 import Control.Exception
15 import Control.Monad ( when )
16 import qualified Data.ByteString.Char8 as B
17 import Data.Char
18 import System.IO
19
20 import Data.List ( sortBy )
21 import Data.Function ( on )
22
23 #if x86_64_TARGET_ARCH
24 #define REWRITE_AVX
25 #endif
26
27 -- Magic Strings
28 secStmt, infoSec, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
29 secStmt = B.pack "\t.section\t"
30 infoSec = B.pack infoSection
31 newLine = B.pack "\n"
32 textStmt = B.pack "\t.text"
33 dataStmt = B.pack "\t.data"
34 syntaxUnified = B.pack "\t.syntax unified"
35
36 infoLen :: Int
37 infoLen = B.length infoSec
38
39 -- Search Predicates
40 isType :: B.ByteString -> Bool
41 isType = B.isPrefixOf (B.pack "\t.type")
42
43 -- section of a file in the form of (header line, contents)
44 type Section = (B.ByteString, B.ByteString)
45
46 -- | Read in assembly file and process
47 llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
48 llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
49 showPass dflags "LlVM Mangler"
50 r <- openBinaryFile f1 ReadMode
51 w <- openBinaryFile f2 WriteMode
52 ss <- readSections r w
53 hClose r
54 let fixed = (map rewriteAVX . fixTables) ss
55 mapM_ (writeSection w) fixed
56 hClose w
57 return ()
58
59 -- | Splits the file contents into its sections
60 readSections :: Handle -> Handle -> IO [Section]
61 readSections r w = go B.empty [] []
62 where
63 go hdr ss ls = do
64 e_l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
65
66 -- Note that ".type" directives at the end of a section refer to
67 -- the first directive of the *next* section, therefore we take
68 -- it over to that section.
69 let (tys, ls') = span isType ls
70 cts = B.intercalate newLine $ reverse ls'
71
72 -- Decide whether to directly output the section or append it
73 -- to the list for resorting.
74 let finishSection
75 | infoSec `B.isInfixOf` hdr =
76 cts `seq` return $ (hdr, cts):ss
77 | otherwise =
78 writeSection w (hdr, cts) >> return ss
79
80 case e_l of
81 Right l | l == syntaxUnified
82 -> finishSection >>= \ss' -> writeSection w (l, B.empty)
83 >> go B.empty ss' tys
84 | any (`B.isPrefixOf` l) [secStmt, textStmt, dataStmt]
85 -> finishSection >>= \ss' -> go l ss' tys
86 | otherwise
87 -> go hdr ss (l:ls)
88 Left _ -> finishSection >>= \ss' -> return (reverse ss')
89
90 -- | Writes sections back
91 writeSection :: Handle -> Section -> IO ()
92 writeSection w (hdr, cts) = do
93 when (not $ B.null hdr) $
94 B.hPutStrLn w hdr
95 B.hPutStrLn w cts
96
97 #if REWRITE_AVX
98 rewriteAVX :: Section -> Section
99 rewriteAVX = rewriteVmovaps . rewriteVmovdqa
100
101 rewriteVmovdqa :: Section -> Section
102 rewriteVmovdqa = rewriteInstructions vmovdqa vmovdqu
103 where
104 vmovdqa, vmovdqu :: B.ByteString
105 vmovdqa = B.pack "vmovdqa"
106 vmovdqu = B.pack "vmovdqu"
107
108 rewriteVmovap :: Section -> Section
109 rewriteVmovap = rewriteInstructions vmovap vmovup
110 where
111 vmovap, vmovup :: B.ByteString
112 vmovap = B.pack "vmovap"
113 vmovup = B.pack "vmovup"
114
115 rewriteInstructions :: B.ByteString -> B.ByteString -> Section -> Section
116 rewriteInstructions matchBS replaceBS (hdr, cts) =
117 (hdr, loop cts)
118 where
119 loop :: B.ByteString -> B.ByteString
120 loop cts =
121 case B.breakSubstring cts matchBS of
122 (hd,tl) | B.null tl -> hd
123 | otherwise -> hd `B.append` replaceBS `B.append`
124 loop (B.drop (B.length matchBS) tl)
125 #else /* !REWRITE_AVX */
126 rewriteAVX :: Section -> Section
127 rewriteAVX = id
128 #endif /* !REWRITE_SSE */
129
130 -- | Reorder and convert sections so info tables end up next to the
131 -- code. Also does stack fixups.
132 fixTables :: [Section] -> [Section]
133 fixTables ss = map strip sorted
134 where
135 -- Resort sections: We only assign a non-zero number to all
136 -- sections having the "STRIP ME" marker. As sortBy is stable,
137 -- this will cause all these sections to be appended to the end of
138 -- the file in the order given by the indexes.
139 extractIx hdr
140 | B.null a = 0
141 | otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a)
142 where (_,a) = B.breakSubstring infoSec hdr
143
144 indexed = zip (map (extractIx . fst) ss) ss
145
146 sorted = map snd $ sortBy (compare `on` fst) indexed
147
148 -- Turn all the "STRIP ME" sections into normal text sections, as
149 -- they are in the right place now.
150 strip (hdr, cts)
151 | infoSec `B.isInfixOf` hdr = (textStmt, cts)
152 | otherwise = (hdr, cts)
153
154 -- | Read an int or error
155 readInt :: B.ByteString -> Int
156 readInt str | B.all isDigit str = (read . B.unpack) str
157 | otherwise = error $ "LLvmMangler Cannot read " ++ show str
158 ++ " as it's not an Int"
159