compiler/llvmGen/LlvmMangler.hs

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