-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
- (before, fheader) = BS.splitAt start bl
- (fun, after) = BS.breakSubstring funDivider al
- label = snd $ BS.breakEnd eolPred bl
-
- -- get the info table
- ilabel = label `BS.append` tableSuf
- (bit, itable) = BS.breakSubstring ilabel after
- (itable', ait) = BS.breakSubstring funDivider itable
- istart = last' $ BS.findSubstrings funDivider bit
- (bit', iheader) = BS.splitAt istart bit
-
- -- fix up sections
- fheader' = replaceSection fheader
- iheader' = replaceSection iheader
-
- function = [before, eol, iheader', itable', eol, fheader', fun, eol]
- remainder = bit' `BS.append` ait
- in if BS.null al
- then do
- BS.appendFile f bl
- return BS.empty
-
- else if BS.null itable
- then error $ "Function without matching info table! ("
- ++ (BS.unpack label) ++ ")"
-
- else do
- mapM_ (BS.appendFile f) function
- return remainder
-
--- | Replace the current section in a function or table header with the
--- text section specifier.
-replaceSection :: ByteString -> ByteString
-replaceSection sec =
- let (s1, s2) = BS.breakSubstring oldSection sec
- s1' = fst $ BS.breakEnd eolPred s1
- s2' = snd $ BS.break eolPred s2
- in s1' `BS.append` newSection `BS.append` s2'
+fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
+fixTables r w m = do
+ f <- getFun r B.empty
+ if B.null f
+ then return ()
+ else let fun = fixupStack f B.empty
+ (a,b) = B.breakSubstring infoSec fun
+ (x,c) = B.break eolPred b
+ fun' = a `B.append` newInfoSec `B.append` c
+ n = readInt $ B.drop infoLen x
+ (bs, m') | B.null b = ([fun], m)
+ | even n = ([], I.insert n fun' m)
+ | otherwise = case I.lookup (n+1) m of
+ Just xf' -> ([fun',xf'], m)
+ Nothing -> ([fun'], m)
+ in mapM_ (B.hPut w) bs >> fixTables r w m'
+
+-- | Read in the next function/data defenition
+getFun :: Handle -> B.ByteString -> IO B.ByteString
+getFun r f = do
+ l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
+ case l of
+ Right l' | B.null l' -> return f
+ | otherwise -> getFun r (f `B.append` newLine `B.append` l')
+ Left _ -> return B.empty
+
+{-|
+ 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). 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 the alignment here.
+-}
+fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
+fixupStack f f' | B.null f' =
+ let -- fixup sub op
+ (a, c) = B.breakSubstring spInst f
+ (b, n) = B.breakEnd dollarPred a
+ num = B.pack $ show $ readInt n + spFix
+ in if B.null c
+ then f' `B.append` f
+ else fixupStack c $ f' `B.append` b `B.append` num
+
+fixupStack f f' =
+ let -- fixup add ops
+ (a, c) = B.breakSubstring jmpInst f
+ -- we matched on a '\n' so go past it
+ (l', b) = B.break eolPred $ B.tail c
+ l = (B.head c) `B.cons` l'
+ (a', n) = B.breakEnd dollarPred a
+ (n', x) = B.break commaPred n
+ num = B.pack $ show $ readInt n' + spFix
+ in if B.null c
+ then f' `B.append` f
+ -- We need to avoid processing jumps to labels, they are of the form:
+ -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
+ else if B.index c labelStart == 'L'
+ then fixupStack b $ f' `B.append` a `B.append` l
+ else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
+ x `B.append` l
+
+-- | read an int or error
+readInt :: B.ByteString -> Int
+readInt str | B.all isDigit str = (read . B.unpack) str
+ | otherwise = error $ "LLvmMangler Cannot read" ++ show str
+ ++ "as it's not an Int"