module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where
import GHC.Prelude
import GHC.Platform ( Platform, platformArch, Arch(..) )
import GHC.Utils.Exception (try)
import qualified Data.ByteString.Char8 as B
import System.IO
llvmFixupAsm :: Platform -> FilePath -> FilePath -> IO ()
llvmFixupAsm platform f1 f2 =
withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
go r w
hClose r
hClose w
return ()
where
go :: Handle -> Handle -> IO ()
go r w = do
e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
let writeline a = B.hPutStrLn w (rewriteLine platform rewrites a) >> go r w
case e_l of
Right l -> writeline l
Left _ -> return ()
rewrites :: [Rewrite]
rewrites = [rewriteSymType, rewriteAVX, rewriteCall]
type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString
rewriteLine :: Platform -> [Rewrite] -> B.ByteString -> B.ByteString
rewriteLine platform rewrites l
| isSubsectionsViaSymbols l =
(B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")
| otherwise =
case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of
Nothing -> l
Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
where
isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")
(symbol, rest) = splitLine l
firstJust :: [Maybe a] -> Maybe a
firstJust (Just x:_) = Just x
firstJust [] = Nothing
firstJust (_:rest) = firstJust rest
rewriteSymType :: Rewrite
rewriteSymType _ l
| isType l = Just $ rewrite '@' $ rewrite '%' l
| otherwise = Nothing
where
isType = B.isPrefixOf (B.pack ".type")
rewrite :: Char -> B.ByteString -> B.ByteString
rewrite prefix = replaceOnce funcType objType
where
funcType = prefix `B.cons` B.pack "function"
objType = prefix `B.cons` B.pack "object"
rewriteAVX :: Rewrite
rewriteAVX platform s
| not isX86_64 = Nothing
| isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
| isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
| otherwise = Nothing
where
isX86_64 = platformArch platform == ArchX86_64
isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
isVmovap = B.isPrefixOf (B.pack "vmovap")
rewriteCall :: Rewrite
rewriteCall platform l
| not isRISCV64 = Nothing
| isCall l = Just $ replaceCall "call" "jalr" "ra" l
| isTail l = Just $ replaceCall "tail" "jr" "t1" l
| otherwise = Nothing
where
isRISCV64 = platformArch platform == ArchRISCV64
isCall = B.isPrefixOf (B.pack "call\t")
isTail = B.isPrefixOf (B.pack "tail\t")
replaceCall call jump reg l =
appendInsn (jump ++ "\t" ++ reg) $ removePlt $
replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l
where
removePlt = replaceOnce (B.pack "@plt") (B.pack "")
appendInsn i = (`B.append` B.pack ("\n\t" ++ i))
replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
replaceOnce matchBS replaceOnceBS = loop
where
loop :: B.ByteString -> B.ByteString
loop cts =
case B.breakSubstring matchBS cts of
(hd,tl) | B.null tl -> hd
| otherwise -> hd `B.append` replaceOnceBS `B.append`
B.drop (B.length matchBS) tl
splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
splitLine l = (symbol, B.dropWhile isSpace rest)
where
isSpace ' ' = True
isSpace '\t' = True
isSpace _ = False
(symbol, rest) = B.span (not . isSpace) l