Remove dead generics-related code from OccName
[ghc.git] / compiler / llvmGen / LlvmMangler.hs
1 -- -----------------------------------------------------------------------------
2 -- | GHC LLVM Mangler
3 --
4 -- This script processes the assembly produced by LLVM, rewriting all symbols
5 -- of type @function to @object. This keeps them from going through the PLT,
6 -- which would be bad due to tables-next-to-code. On x86_64,
7 -- it also rewrites AVX instructions that require alignment to their
8 -- unaligned counterparts, since the stack is only 16-byte aligned but these
9 -- instructions require 32-byte alignment.
10 --
11
12 module LlvmMangler ( llvmFixupAsm ) where
13
14 import DynFlags ( DynFlags, targetPlatform )
15 import Platform ( platformArch, Arch(..) )
16 import ErrUtils ( withTiming )
17 import Outputable ( text )
18
19 import Control.Exception
20 import qualified Data.ByteString.Char8 as B
21 import System.IO
22
23 -- | Read in assembly file and process
24 llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
25 llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
26 withTiming (pure dflags) (text "LLVM Mangler") id $
27 withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
28 go r w
29 hClose r
30 hClose w
31 return ()
32 where
33 go :: Handle -> Handle -> IO ()
34 go r w = do
35 e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
36 let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w
37 case e_l of
38 Right l -> writeline l
39 Left _ -> return ()
40
41 -- | These are the rewrites that the mangler will perform
42 rewrites :: [Rewrite]
43 rewrites = [rewriteSymType, rewriteAVX]
44
45 type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
46
47 -- | Rewrite a line of assembly source with the given rewrites,
48 -- taking the first rewrite that applies.
49 rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
50 rewriteLine dflags rewrites l =
51 case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of
52 Nothing -> l
53 Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
54 where
55 (symbol, rest) = splitLine l
56
57 firstJust :: [Maybe a] -> Maybe a
58 firstJust (Just x:_) = Just x
59 firstJust [] = Nothing
60 firstJust (_:rest) = firstJust rest
61
62 -- | This rewrites @.type@ annotations of function symbols to @%object@.
63 -- This is done as the linker can relocate @%functions@ through the
64 -- Procedure Linking Table (PLT). This is bad since we expect that the
65 -- info table will appear directly before the symbol's location. In the
66 -- case that the PLT is used, this will be not an info table but instead
67 -- some random PLT garbage.
68 rewriteSymType :: Rewrite
69 rewriteSymType _ l
70 | isType l = Just $ rewrite '@' $ rewrite '%' l
71 | otherwise = Nothing
72 where
73 isType = B.isPrefixOf (B.pack ".type")
74
75 rewrite :: Char -> B.ByteString -> B.ByteString
76 rewrite prefix = replaceOnce funcType objType
77 where
78 funcType = prefix `B.cons` B.pack "function"
79 objType = prefix `B.cons` B.pack "object"
80
81 -- | This rewrites aligned AVX instructions to their unaligned counterparts on
82 -- x86-64. This is necessary because the stack is not adequately aligned for
83 -- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer
84 -- and disable tail call optimization. Both would be catastrophic here so GHC
85 -- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then
86 -- rewrites the instructions in the mangler.
87 rewriteAVX :: Rewrite
88 rewriteAVX dflags s
89 | not isX86_64 = Nothing
90 | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
91 | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
92 | otherwise = Nothing
93 where
94 isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64
95 isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
96 isVmovap = B.isPrefixOf (B.pack "vmovap")
97
98 -- | @replaceOnce match replace bs@ replaces the first occurrence of the
99 -- substring @match@ in @bs@ with @replace@.
100 replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
101 replaceOnce matchBS replaceOnceBS = loop
102 where
103 loop :: B.ByteString -> B.ByteString
104 loop cts =
105 case B.breakSubstring matchBS cts of
106 (hd,tl) | B.null tl -> hd
107 | otherwise -> hd `B.append` replaceOnceBS `B.append`
108 B.drop (B.length matchBS) tl
109
110 -- | This function splits a line of assembly code into the label and the
111 -- rest of the code.
112 splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
113 splitLine l = (symbol, B.dropWhile isSpace rest)
114 where
115 isSpace ' ' = True
116 isSpace '\t' = True
117 isSpace _ = False
118 (symbol, rest) = B.span (not . isSpace) l