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