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. We also
   6 -- use it to fix up the stack alignment, which needs to be 16 byte aligned
   7 -- but always ends up off by 4 bytes because GHC sets it to the 'wrong'
   8 -- starting value in the RTS.
   9 --
  10 -- We only need this for Mac OS X, other targets don't use it.
  11 --
  12
  13 module LlvmMangler ( llvmFixupAsm ) where
  14
  15 import Control.Exception
  16 import qualified Data.ByteString.Char8 as B
  17 import Data.Char
  18 import qualified Data.IntMap as I
  19 import System.IO
  20
  21 -- Magic Strings
  22 infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
  23 infoSec    = B.pack "\t.section\t__STRIP,__me"
  24 newInfoSec = B.pack "\n\t.text"
  25 newLine    = B.pack "\n"
  26 spInst     = B.pack ", %esp\n"
  27 jmpInst    = B.pack "jmp"
  28
  29 infoLen, spFix :: Int
  30 infoLen = B.length infoSec
  31 spFix   = 4
  32
  33 -- Search Predicates
  34 eolPred, dollarPred, commaPred :: Char -> Bool
  35 eolPred    = ((==) '\n')
  36 dollarPred = ((==) '$')
  37 commaPred  = ((==) ',')
  38
  39 -- | Read in assembly file and process
  40 llvmFixupAsm :: FilePath -> FilePath -> IO ()
  41 llvmFixupAsm f1 f2 = do
  42     r <- openBinaryFile f1 ReadMode
  43     w <- openBinaryFile f2 WriteMode
  44     fixTables r w I.empty
  45     B.hPut w (B.pack "\n\n")
  46     hClose r
  47     hClose w
  48     return ()
  49
  50 {- |
  51     Here we process the assembly file one function and data
  52     defenition at a time. When a function is encountered that
  53     should have a info table we store it in a map. Otherwise
  54     we print it. When an info table is found we retrieve its
  55     function from the map and print them both.
  56
  57     For all functions we fix up the stack alignment. We also
  58     fix up the section defenition for functions and info tables.
  59 -}
  60 fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
  61 fixTables r w m = do
  62     f <- getFun r B.empty
  63     if B.null f
  64        then return ()
  65        else let fun   = fixupStack f B.empty
  66                 (a,b) = B.breakSubstring infoSec fun
  67                 (x,c) = B.break eolPred b
  68                 fun'  = a `B.append` newInfoSec `B.append` c
  69                 n     = readInt $ B.drop infoLen x
  70                 (bs, m') | B.null b  = ([fun], m)
  71                          | even n    = ([], I.insert n fun' m)
  72                          | otherwise = case I.lookup (n+1) m of
  73                                Just xf' -> ([fun',xf'], m)
  74                                Nothing  -> ([fun'], m)
  75             in mapM_ (B.hPut w) bs >> fixTables r w m'
  76
  77 -- | Read in the next function/data defenition
  78 getFun :: Handle -> B.ByteString -> IO B.ByteString
  79 getFun r f = do
  80     l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
  81     case l of
  82         Right l' | B.null l' -> return f
  83                  | otherwise -> getFun r (f `B.append` newLine `B.append` l')
  84         Left _ -> return B.empty
  85
  86 {-|
  87     Mac OS X requires that the stack be 16 byte aligned when making a function
  88     call (only really required though when making a call that will pass through
  89     the dynamic linker). The alignment isn't correctly generated by LLVM as
  90     LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
  91     (since the function call was 16 byte aligned and the return address should
  92     have been pushed, so sub 4). GHC though since it always uses jumps keeps
  93     the stack 16 byte aligned on both function calls and function entry.
  94
  95     We correct the alignment here.
  96 -}
  97 fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
  98 fixupStack f f' | B.null f' =
  99     let -- fixup sub op
 100         (a, c) = B.breakSubstring spInst f
 101         (b, n) = B.breakEnd dollarPred a
 102         num    = B.pack $ show $ readInt n + spFix
 103     in if B.null c
 104           then f' `B.append` f
 105           else fixupStack c $ f' `B.append` b `B.append` num
 106
 107 fixupStack f f' =
 108     let -- fixup add ops
 109         (a, c)  = B.breakSubstring jmpInst f
 110         (l, b)  = B.break eolPred c
 111         (a', n) = B.breakEnd dollarPred a
 112         (n', x) = B.break commaPred n
 113         num     = B.pack $ show $ readInt n' + spFix
 114     in if B.null c
 115           then f' `B.append` f
 116           -- We need to avoid processing jumps to labels, they are of the form:
 117           -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
 118           else if B.index c 4 == 'L'
 119                 then fixupStack b $ f' `B.append` a `B.append` l
 120                 else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
 121                                     x `B.append` l
 122
 123 -- | read an int or error
 124 readInt :: B.ByteString -> Int
 125 readInt str | B.all isDigit str = (read . B.unpack) str
 126                 | otherwise = error $ "LLvmMangler Cannot read" ++ show str
 127                                 ++ "as it's not an Int"
 128