module LlvmMangler ( llvmFixupAsm ) where
#include "HsVersions.h"
import LlvmCodeGen.Ppr ( infoSection )
import Control.Exception
import Control.Monad ( when )
import qualified Data.ByteString.Char8 as B
import Data.Char
import System.IO
import Data.List ( sortBy )
import Data.Function ( on )
secStmt, infoSec, newLine, spInst, jmpInst, textStmt, dataStmt :: B.ByteString
secStmt = B.pack "\t.section\t"
infoSec = B.pack infoSection
newLine = B.pack "\n"
jmpInst = B.pack "\n\tjmp"
textStmt = B.pack "\t.text"
dataStmt = B.pack "\t.data"
infoLen, labelStart, spFix :: Int
infoLen = B.length infoSec
labelStart = B.length jmpInst
#if x86_64_TARGET_ARCH
spInst = B.pack ", %rsp\n"
spFix = 8
#else
spInst = B.pack ", %esp\n"
spFix = 4
#endif
eolPred, dollarPred, commaPred :: Char -> Bool
eolPred = ((==) '\n')
dollarPred = ((==) '$')
commaPred = ((==) ',')
llvmFixupAsm :: FilePath -> FilePath -> IO ()
llvmFixupAsm f1 f2 = do
r <- openBinaryFile f1 ReadMode
w <- openBinaryFile f2 WriteMode
ss <- readSections r w
hClose r
let fixed = fixTables ss
mapM_ (writeSection w) fixed
hClose w
return ()
type Section = (B.ByteString, B.ByteString)
readSections :: Handle -> Handle -> IO [Section]
readSections r w = go B.empty [] []
where
go hdr ss ls = do
e_l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
let (tys, ls') = span isType ls
isType = B.isPrefixOf (B.pack "\t.type")
cts = B.intercalate newLine $ reverse ls'
let finishSection
| infoSec `B.isInfixOf` hdr =
cts `seq` return $ (hdr, cts):ss
| otherwise =
writeSection w (hdr, fixupStack cts B.empty) >> return ss
case e_l of
Right l | any (`B.isPrefixOf` l) [secStmt, textStmt, dataStmt]
-> finishSection >>= \ss' -> go l ss' tys
| otherwise
-> go hdr ss (l:ls)
Left _ -> finishSection >>= \ss' -> return (reverse ss')
writeSection :: Handle -> Section -> IO ()
writeSection w (hdr, cts) = do
when (not $ B.null hdr) $
B.hPutStrLn w hdr
B.hPutStrLn w cts
fixTables :: [Section] -> [Section]
fixTables ss = fixed
where
extractIx hdr
| B.null a = 0
| otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a)
where (_,a) = B.breakSubstring infoSec hdr
indexed = zip (map (extractIx . fst) ss) ss
sorted = map snd $ sortBy (compare `on` fst) indexed
strip (hdr, cts)
| infoSec `B.isInfixOf` hdr = (textStmt, cts)
| otherwise = (hdr, cts)
stripped = map strip sorted
fix (hdr, cts) = (hdr, fixupStack cts B.empty)
fixed = map fix stripped
fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
#if !darwin_TARGET_OS
fixupStack = const
#else
fixupStack f f' | B.null f' =
let
(a, c) = B.breakSubstring spInst f
(b, n) = B.breakEnd dollarPred a
num = B.pack $ show $ readInt n + spFix
in if B.null c
then f' `B.append` f
else fixupStack c $ f' `B.append` b `B.append` num
fixupStack f f' =
let
(a, c) = B.breakSubstring jmpInst f
(l', b) = B.break eolPred $ B.tail c
l = (B.head c) `B.cons` l'
(a', n) = B.breakEnd dollarPred a
(n', x) = B.break commaPred n
num = B.pack $ show $ readInt n' + spFix
targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $
B.drop labelStart c
in if B.null c
then f' `B.append` f
else if B.head targ == 'L'
then fixupStack b $ f' `B.append` a `B.append` l
else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
x `B.append` l
#endif
readInt :: B.ByteString -> Int
readInt str | B.all isDigit str = (read . B.unpack) str
| otherwise = error $ "LLvmMangler Cannot read " ++ show str
++ " as it's not an Int"