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
 
 -- -----------------------------------------------------------------------------
 -- | GHC LLVM Mangler

--- 
+--

 -- This script processes the assembly produced by LLVM, rearranging the code
 -- 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
 
 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"
 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:"
 functionSuf = BS.pack "_info:"

-tableSuf    = BS.pack "_info_itable:"
+tableSuf    = BS.pack $ "_info" ++ iTableSuf ++ ":"

 funDivider  = BS.pack "\n\n"
 eol         = BS.pack "\n"
 
 funDivider  = BS.pack "\n\n"
 eol         = BS.pack "\n"
 

-eolPred :: Char -> Bool
+
+eolPred, dollarPred, commaPred :: Char -> Bool

 eolPred = ((==) '\n')
 eolPred = ((==) '\n')

+dollarPred = ((==) '$')
+commaPred = ((==) ',')

 
 -- | Read in assembly file and process
 llvmFixupAsm :: FilePath -> FilePath -> IO ()
 
 -- | 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.
   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.
   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>:
   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
 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
         -- 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
 
         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
 
         -- 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
         remainder = bit' `BS.append` ait
     in if BS.null al

-          then do 
+          then do

               BS.appendFile f bl
               return BS.empty
 
               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'
 
         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)
+