module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where
import GHC.Prelude
import GHC.Driver.Session ( DynFlags, targetPlatform )
import GHC.Platform ( platformArch, Arch(..) )
import GHC.Utils.Error ( withTiming )
import GHC.Utils.Outputable ( text )
import GHC.Utils.Logger
import Control.Exception
import qualified Data.ByteString.Char8 as B
import System.IO
llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm Logger
logger DynFlags
dflags FilePath
f1 FilePath
f2 = {-# SCC "llvm_mangler" #-}
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (FilePath -> SDoc
text FilePath
"LLVM Mangler") forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
f1 IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
r -> forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
f2 IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
w -> do
Handle -> Handle -> IO ()
go Handle
r Handle
w
Handle -> IO ()
hClose Handle
r
Handle -> IO ()
hClose Handle
w
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
go :: Handle -> Handle -> IO ()
go :: Handle -> Handle -> IO ()
go Handle
r Handle
w = do
Either IOError ByteString
e_l <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
B.hGetLine Handle
r ::IO (Either IOError B.ByteString)
let writeline :: ByteString -> IO ()
writeline ByteString
a = Handle -> ByteString -> IO ()
B.hPutStrLn Handle
w (DynFlags -> [Rewrite] -> ByteString -> ByteString
rewriteLine DynFlags
dflags [Rewrite]
rewrites ByteString
a) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Handle -> IO ()
go Handle
r Handle
w
case Either IOError ByteString
e_l of
Right ByteString
l -> ByteString -> IO ()
writeline ByteString
l
Left IOError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
rewrites :: [Rewrite]
rewrites :: [Rewrite]
rewrites = [Rewrite
rewriteSymType, Rewrite
rewriteAVX]
type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
rewriteLine :: DynFlags -> [Rewrite] -> ByteString -> ByteString
rewriteLine DynFlags
dflags [Rewrite]
rewrites ByteString
l
| ByteString -> Bool
isSubsectionsViaSymbols ByteString
l =
(FilePath -> ByteString
B.pack FilePath
"## no .subsection_via_symbols for ghc. We need our info tables!")
| Bool
otherwise =
case forall a. [Maybe a] -> Maybe a
firstJust forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Rewrite
rewrite -> Rewrite
rewrite DynFlags
dflags ByteString
rest) [Rewrite]
rewrites of
Maybe ByteString
Nothing -> ByteString
l
Just ByteString
rewritten -> [ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$ [ByteString
symbol, FilePath -> ByteString
B.pack FilePath
"\t", ByteString
rewritten]
where
isSubsectionsViaSymbols :: ByteString -> Bool
isSubsectionsViaSymbols = ByteString -> ByteString -> Bool
B.isPrefixOf (FilePath -> ByteString
B.pack FilePath
".subsections_via_symbols")
(ByteString
symbol, ByteString
rest) = ByteString -> (ByteString, ByteString)
splitLine ByteString
l
firstJust :: [Maybe a] -> Maybe a
firstJust :: forall a. [Maybe a] -> Maybe a
firstJust (Just a
x:[Maybe a]
_) = forall a. a -> Maybe a
Just a
x
firstJust [] = forall a. Maybe a
Nothing
firstJust (Maybe a
_:[Maybe a]
rest) = forall a. [Maybe a] -> Maybe a
firstJust [Maybe a]
rest
rewriteSymType :: Rewrite
rewriteSymType :: Rewrite
rewriteSymType DynFlags
_ ByteString
l
| ByteString -> Bool
isType ByteString
l = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> ByteString
rewrite Char
'@' forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> ByteString
rewrite Char
'%' ByteString
l
| Bool
otherwise = forall a. Maybe a
Nothing
where
isType :: ByteString -> Bool
isType = ByteString -> ByteString -> Bool
B.isPrefixOf (FilePath -> ByteString
B.pack FilePath
".type")
rewrite :: Char -> B.ByteString -> B.ByteString
rewrite :: Char -> ByteString -> ByteString
rewrite Char
prefix = ByteString -> ByteString -> ByteString -> ByteString
replaceOnce ByteString
funcType ByteString
objType
where
funcType :: ByteString
funcType = Char
prefix Char -> ByteString -> ByteString
`B.cons` FilePath -> ByteString
B.pack FilePath
"function"
objType :: ByteString
objType = Char
prefix Char -> ByteString -> ByteString
`B.cons` FilePath -> ByteString
B.pack FilePath
"object"
rewriteAVX :: Rewrite
rewriteAVX :: Rewrite
rewriteAVX DynFlags
dflags ByteString
s
| Bool -> Bool
not Bool
isX86_64 = forall a. Maybe a
Nothing
| ByteString -> Bool
isVmovdqa ByteString
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString -> ByteString
replaceOnce (FilePath -> ByteString
B.pack FilePath
"vmovdqa") (FilePath -> ByteString
B.pack FilePath
"vmovdqu") ByteString
s
| ByteString -> Bool
isVmovap ByteString
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString -> ByteString
replaceOnce (FilePath -> ByteString
B.pack FilePath
"vmovap") (FilePath -> ByteString
B.pack FilePath
"vmovup") ByteString
s
| Bool
otherwise = forall a. Maybe a
Nothing
where
isX86_64 :: Bool
isX86_64 = Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) forall a. Eq a => a -> a -> Bool
== Arch
ArchX86_64
isVmovdqa :: ByteString -> Bool
isVmovdqa = ByteString -> ByteString -> Bool
B.isPrefixOf (FilePath -> ByteString
B.pack FilePath
"vmovdqa")
isVmovap :: ByteString -> Bool
isVmovap = ByteString -> ByteString -> Bool
B.isPrefixOf (FilePath -> ByteString
B.pack FilePath
"vmovap")
replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
replaceOnce :: ByteString -> ByteString -> ByteString -> ByteString
replaceOnce ByteString
matchBS ByteString
replaceOnceBS = ByteString -> ByteString
loop
where
loop :: B.ByteString -> B.ByteString
loop :: ByteString -> ByteString
loop ByteString
cts =
case ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
matchBS ByteString
cts of
(ByteString
hd,ByteString
tl) | ByteString -> Bool
B.null ByteString
tl -> ByteString
hd
| Bool
otherwise -> ByteString
hd ByteString -> ByteString -> ByteString
`B.append` ByteString
replaceOnceBS ByteString -> ByteString -> ByteString
`B.append`
Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
matchBS) ByteString
tl
splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
splitLine :: ByteString -> (ByteString, ByteString)
splitLine ByteString
l = (ByteString
symbol, (Char -> Bool) -> ByteString -> ByteString
B.dropWhile Char -> Bool
isSpace ByteString
rest)
where
isSpace :: Char -> Bool
isSpace Char
' ' = Bool
True
isSpace Char
'\t' = Bool
True
isSpace Char
_ = Bool
False
(ByteString
symbol, ByteString
rest) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
B.span (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) ByteString
l