-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
-
- -- fixup stack alignment
- fun' = fixupStack fun BS.empty
-
- -- 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 ghciTablesNextToCode
- then if BS.null itable
- then error $ "Function without matching info table! ("
- ++ (BS.unpack label) ++ ")"
- else do
- mapM_ (BS.appendFile f) function
- return remainder
-
- else do
- -- TNTC not turned on so just fix up stack
- mapM_ (BS.appendFile f) [before, fheader, fun']
- return after
-
--- | 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'
-
-
--- | 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 =
+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' =