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