compiler/llvmGen/LlvmMangler.hs

   1 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   2
   3 -- -----------------------------------------------------------------------------
   4 -- | GHC LLVM Mangler
   5 --
   6 -- This script processes the assembly produced by LLVM, rearranging the code
   7 -- so that an info table appears before its corresponding function. We also
   8 -- use it to fix up the stack alignment, which needs to be 16 byte aligned
   9 -- but always ends up off by 4 bytes because GHC sets it to the wrong starting
  10 -- value in the RTS.
  11 --
  12 -- We only need this for Mac OS X, other targets don't use it.
  13 --
  14
  15 module LlvmMangler ( llvmFixupAsm ) where
  16
  17 import Data.ByteString.Char8 ( ByteString )
  18 import qualified Data.ByteString.Char8 as BS
  19
  20 import LlvmCodeGen.Ppr ( infoSection, iTableSuf )
  21
  22
  23 {- Configuration. -}
  24 newSection, oldSection, functionSuf, tableSuf, funDivider, eol :: ByteString
  25 newSection  = BS.pack "\n.text\n"
  26 oldSection  = BS.pack infoSection
  27 functionSuf = BS.pack "_info:"
  28 tableSuf    = BS.pack $ "_info" ++ iTableSuf ++ ":"
  29 funDivider  = BS.pack "\n\n"
  30 eol         = BS.pack "\n"
  31
  32
  33 eolPred, dollarPred, commaPred :: Char -> Bool
  34 eolPred = ((==) '\n')
  35 dollarPred = ((==) '$')
  36 commaPred = ((==) ',')
  37
  38 -- | Read in assembly file and process
  39 llvmFixupAsm :: FilePath -> FilePath -> IO ()
  40 llvmFixupAsm f1 f2 = do
  41     asm <- BS.readFile f1
  42     BS.writeFile f2 BS.empty
  43     allTables f2 asm
  44     return ()
  45
  46 -- | Run over whole assembly file
  47 allTables :: FilePath -> ByteString -> IO ()
  48 allTables f str = do
  49     rem <- oneTable f str
  50     if BS.null rem
  51        then return ()
  52        else allTables f rem
  53
  54 {- |
  55   Look for the next function that needs to have its info table
  56   arranged to be before it and process it. This will print out
  57   any code before this function, then the info table, then the
  58   function. It will return the remainder of the assembly code
  59   to process.
  60
  61   We rely here on the fact that LLVM prints all global variables
  62   at the end of the file, so an info table will always appear
  63   after its function.
  64
  65   To try to help explain the string searches, here is some
  66   assembly code that would be processed by this program, with
  67   split markers placed in it like so, <split marker>:
  68
  69     [ ...asm code... ]
  70     jmp *%eax
  71     <before|fheader>
  72     .def Main_main_info
  73     .section TEXT
  74     .globl _Main_main_info
  75     _Main_main<bl|al>_info:
  76         sub $12, %esp
  77         [ ...asm code... ]
  78         jmp *%eax
  79     <fun|after>
  80     .def .....
  81
  82     [ ...asm code... ]
  83
  84         .long 231231
  85     <bit'|itable_h>
  86     .section TEXT
  87     .global _Main_main_entry
  88     .align 4
  89     <bit|itable>_Main_main_entry:
  90         .long 0
  91         [ ...asm code... ]
  92     <itable'|ait>
  93     .section TEXT
  94 -}
  95 oneTable :: FilePath -> ByteString -> IO ByteString
  96 oneTable f str =
  97     let last' xs = if (null xs) then 0 else last xs
  98
  99         -- get the function
 100         (bl, al) = BS.breakSubstring functionSuf str
 101         start = last' $ BS.findSubstrings funDivider bl
 102         (before, fheader) = BS.splitAt start bl
 103         (fun, after) = BS.breakSubstring funDivider al
 104         label = snd $ BS.breakEnd eolPred bl
 105
 106         -- get the info table
 107         ilabel = label `BS.append` tableSuf
 108         (bit, itable) = BS.breakSubstring ilabel after
 109         (itable', ait) = BS.breakSubstring funDivider itable
 110         istart = last' $ BS.findSubstrings funDivider bit
 111         (bit', iheader) = BS.splitAt istart bit
 112
 113         -- fixup stack alignment
 114         fun' = fixupStack fun BS.empty
 115
 116         -- fix up sections
 117         fheader' = replaceSection fheader
 118         iheader' = replaceSection iheader
 119
 120         function = [before, eol, iheader', itable', eol, fheader', fun', eol]
 121         remainder = bit' `BS.append` ait
 122     in if BS.null al
 123           then do
 124               BS.appendFile f bl
 125               return BS.empty
 126
 127           else if BS.null itable
 128                   then error $ "Function without matching info table! ("
 129                               ++ (BS.unpack label) ++ ")"
 130
 131                   else do
 132                       mapM_ (BS.appendFile f) function
 133                       return remainder
 134
 135 -- | Replace the current section in a function or table header with the
 136 -- text section specifier.
 137 replaceSection :: ByteString -> ByteString
 138 replaceSection sec =
 139     let (s1, s2) = BS.breakSubstring oldSection sec
 140         s1' = fst $ BS.breakEnd eolPred s1
 141         s2' = snd $ BS.break eolPred s2
 142     in s1' `BS.append` newSection `BS.append` s2'
 143
 144
 145 -- | Mac OS X requires that the stack be 16 byte aligned when making a function
 146 -- call (only really required though when making a call that will pass through
 147 -- the dynamic linker). During code generation we marked any points where we
 148 -- make a call that requires this alignment. The alignment isn't correctly
 149 -- generated by LLVM as LLVM rightly assumes that the stack wil be aligned to
 150 -- 16n + 12 on entry (since the function call was 16 byte aligned and the return
 151 -- address should have been pushed, so sub 4). GHC though since it always uses
 152 -- jumps keeps the stack 16 byte aligned on both function calls and function
 153 -- entry. We correct LLVM's alignment then by putting inline assembly in that
 154 -- subtracts and adds 4 to the sp as required.
 155 fixupStack :: ByteString -> ByteString -> ByteString
 156 fixupStack fun nfun | BS.null nfun =
 157     let -- fixup sub op
 158         (a, b) = BS.breakSubstring (BS.pack ", %esp\n") fun
 159         (a', num) = BS.breakEnd dollarPred a
 160         num' = BS.pack $ show (read (BS.unpack num) + 4)
 161         fix = a' `BS.append` num'
 162     in if BS.null b
 163           then nfun `BS.append` a
 164           else fixupStack b (nfun `BS.append` fix)
 165
 166 fixupStack fun nfun =
 167     let -- fixup add ops
 168         (a, b) = BS.breakSubstring (BS.pack "jmp") fun
 169         -- We need to avoid processing jumps to labels, they are of the form:
 170         -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
 171         labelJump = BS.index b 4 == 'L'
 172         (jmp, b') = BS.break eolPred b
 173         (a', numx) = BS.breakEnd dollarPred a
 174         (num, x) = BS.break commaPred numx
 175         num' = BS.pack $ show (read (BS.unpack num) + 4)
 176         fix = a' `BS.append` num' `BS.append` x `BS.append` jmp
 177     in if BS.null b
 178           then nfun `BS.append` a
 179           else if labelJump
 180                 then fixupStack b' (nfun `BS.append` a `BS.append` jmp)
 181                 else fixupStack b' (nfun `BS.append` fix)
 182