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