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