LLVM: Use mangler to fix up stack alignment issues on OSX

[ghc-hetmet.git] / compiler / llvmGen / LlvmMangler.hs

diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 54eead1..2fbe324 100644 (file)
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -2,27 +2,38 @@
 
 -- -----------------------------------------------------------------------------
 -- | GHC LLVM Mangler
--- 
+--
 -- This script processes the assembly produced by LLVM, rearranging the code
--- so that an info table appears before its corresponding function.
+-- so that an info table appears before its corresponding function. We also
+-- use it to fix up the stack alignment, which needs to be 16 byte aligned
+-- but always ends up off by 4 bytes because GHC sets it to the wrong starting
+-- value in the RTS.
+--
+-- We only need this for Mac OS X, other targets don't use it.
+--
+
 module LlvmMangler ( llvmFixupAsm ) where
 
 import Data.ByteString.Char8 ( ByteString )
 import qualified Data.ByteString.Char8 as BS
 
-{-
-  Configuration.
--}
+import LlvmCodeGen.Ppr ( infoSection, iTableSuf )
+
+
+{- Configuration. -}
 newSection, oldSection, functionSuf, tableSuf, funDivider, eol :: ByteString
 newSection  = BS.pack "\n.text\n"
-oldSection  = BS.pack "__STRIP,__me"
+oldSection  = BS.pack infoSection
 functionSuf = BS.pack "_info:"
-tableSuf    = BS.pack "_info_itable:"
+tableSuf    = BS.pack $ "_info" ++ iTableSuf ++ ":"
 funDivider  = BS.pack "\n\n"
 eol         = BS.pack "\n"
 
-eolPred :: Char -> Bool
+
+eolPred, dollarPred, commaPred :: Char -> Bool
 eolPred = ((==) '\n')
+dollarPred = ((==) '$')
+commaPred = ((==) ',')
 
 -- | Read in assembly file and process
 llvmFixupAsm :: FilePath -> FilePath -> IO ()
@@ -46,11 +57,11 @@ allTables f str = do
   any code before this function, then the info table, then the
   function. It will return the remainder of the assembly code
   to process.
- 
+
   We rely here on the fact that LLVM prints all global variables
   at the end of the file, so an info table will always appear
   after its function.
-  
+
   To try to help explain the string searches, here is some
   assembly code that would be processed by this program, with
   split markers placed in it like so, <split marker>:
@@ -84,7 +95,7 @@ allTables f str = do
 oneTable :: FilePath -> ByteString -> IO ByteString
 oneTable f str =
     let last' xs = if (null xs) then 0 else last xs
-        
+
         -- get the function
         (bl, al) = BS.breakSubstring functionSuf str
         start = last' $ BS.findSubstrings funDivider bl
@@ -99,14 +110,17 @@ oneTable f str =
         istart = last' $ BS.findSubstrings funDivider bit
         (bit', iheader) = BS.splitAt istart bit
 
+        -- fixup stack alignment
+        fun' = fixupStack fun BS.empty
+
         -- fix up sections
         fheader' = replaceSection fheader
         iheader' = replaceSection iheader
 
-        function = [before, eol, iheader', itable', eol, fheader', fun, eol]
+        function = [before, eol, iheader', itable', eol, fheader', fun', eol]
         remainder = bit' `BS.append` ait
     in if BS.null al
-          then do 
+          then do
               BS.appendFile f bl
               return BS.empty
 
@@ -127,3 +141,42 @@ replaceSection sec =
         s2' = snd $ BS.break eolPred s2
     in s1' `BS.append` newSection `BS.append` s2'
 
+
+-- | Mac OS X requires that the stack be 16 byte aligned when making a function
+-- call (only really required though when making a call that will pass through
+-- the dynamic linker). During code generation we marked any points where we
+-- make a call that requires this alignment. The alignment isn't correctly
+-- generated by LLVM as LLVM rightly assumes that the stack wil be aligned to
+-- 16n + 12 on entry (since the function call was 16 byte aligned and the return
+-- address should have been pushed, so sub 4). GHC though since it always uses
+-- jumps keeps the stack 16 byte aligned on both function calls and function
+-- entry. We correct LLVM's alignment then by putting inline assembly in that
+-- subtracts and adds 4 to the sp as required.
+fixupStack :: ByteString -> ByteString -> ByteString
+fixupStack fun nfun | BS.null nfun =
+    let -- fixup sub op
+        (a, b) = BS.breakSubstring (BS.pack ", %esp\n") fun
+        (a', num) = BS.breakEnd dollarPred a
+        num' = BS.pack $ show (read (BS.unpack num) + 4)
+        fix = a' `BS.append` num'
+    in if BS.null b
+          then nfun `BS.append` a
+          else fixupStack b (nfun `BS.append` fix)
+
+fixupStack fun nfun =
+    let -- fixup add ops
+        (a, b) = BS.breakSubstring (BS.pack "jmp") fun
+        -- We need to avoid processing jumps to labels, they are of the form:
+        -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
+        labelJump = BS.index b 4 == 'L'
+        (jmp, b') = BS.break eolPred b
+        (a', numx) = BS.breakEnd dollarPred a
+        (num, x) = BS.break commaPred numx
+        num' = BS.pack $ show (read (BS.unpack num) + 4)
+        fix = a' `BS.append` num' `BS.append` x `BS.append` jmp
+    in if BS.null b
+          then nfun `BS.append` a
+          else if labelJump
+                then fixupStack b' (nfun `BS.append` a `BS.append` jmp)
+                else fixupStack b' (nfun `BS.append` fix)
+