--
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
llvmCodeGen dflags h us cmms
- = do
- bufh <- newBufHandle h
-
- Prt.bufLeftRender bufh $ pprLlvmHeader
-
- env' <- cmmDataLlvmGens dflags bufh env cdata []
- cmmProcLlvmGens dflags bufh us env' cmm 1 []
-
- bFlush bufh
-
- return ()
- where
- cmm = concat $ map (\(Cmm top) -> top) cmms
-
+ = let cmm = concat $ map (\(Cmm top) -> top) cmms
(cdata,env) = foldr split ([],initLlvmEnv) cmm
-
split (CmmData s d' ) (d,e) = ((s,d'):d,e)
split (CmmProc i l _ _) (d,e) =
let lbl = strCLabel_llvm $ if not (null i)
else l
env' = funInsert lbl llvmFunTy e
in (d,env')
+ in do
+ bufh <- newBufHandle h
+ Prt.bufLeftRender bufh $ pprLlvmHeader
+
+ env' <- cmmDataLlvmGens dflags bufh env cdata []
+ cmmProcLlvmGens dflags bufh us env' cmm 1 []
+
+ bFlush bufh
+ return ()
-- -----------------------------------------------------------------------------
usedArray = LMStaticArray (map cast ivars) ty
lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
- in do
- Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
+ in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
= do
type LlvmStatements = OrdList LlvmStatement
+
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM proc Code generator
--
basicBlocksCodeGen env ([]) (blocks, tops)
= do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
let allocs' = concat allocs
- let ((BasicBlock id fstmts):rblocks) = blocks'
+ let ((BasicBlock id fstmts):rblks) = blocks'
fplog <- funPrologue
- let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblocks
+ let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblks
return (env, fblocks, tops)
basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
basicBlocksCodeGen env' blocks (lblocks, ltops)
--- | Generate code for one block
-basicBlockCodeGen :: LlvmEnv
- -> CmmBasicBlock
- -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
-basicBlockCodeGen env (BasicBlock id stmts)
- = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
- return (env', [BasicBlock id (fromOL instrs)], top)
-
-
-- | Allocations need to be extracted so they can be moved to the entry
-- of a function to make sure they dominate all possible paths in the CFG.
dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
where
(allstmts, allallocs) = foldl split ([],[]) stmts
split (stmts', allocs) s@(Assignment _ (Alloca _ _))
- = (stmts', allocs ++ [s])
+ = (stmts', allocs ++ [s])
split (stmts', allocs) other
- = (stmts' ++ [other], allocs)
+ = (stmts' ++ [other], allocs)
+
+
+-- | Generate code for one block
+basicBlockCodeGen :: LlvmEnv
+ -> CmmBasicBlock
+ -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
+basicBlockCodeGen env (BasicBlock id stmts)
+ = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
+ return (env', [BasicBlock id (fromOL instrs)], top)
-- -----------------------------------------------------------------------------
--
module LlvmCodeGen.Ppr (
- pprLlvmHeader, pprLlvmCmmTop, pprLlvmData
+ pprLlvmHeader, pprLlvmCmmTop, pprLlvmData, infoSection, iTableSuf
) where
#include "HsVersions.h"
import Pretty
import Unique
+
-- ----------------------------------------------------------------------------
-- * Top level
--
setSection ((LMGlobalVar _ ty l _ _ c), d)
= let sec = mkLayoutSection count
ilabel = strCLabel_llvm (entryLblToInfoLbl lbl)
- `appendFS` (fsLit "_itable")
+ `appendFS` fsLit iTableSuf
gv = LMGlobalVar ilabel ty l sec llvmInfAlign c
v = if l == Internal then [gv] else []
in ((gv, d), v)
then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
else (pprLlvmData ([ldata'], ltypes), llvmUsed)
+-- | We generate labels for info tables by converting them to the same label
+-- as for the entry code but adding this string as a suffix.
+iTableSuf :: String
+iTableSuf = "_itable"
+
-- | Create an appropriate section declaration for subsection <n> of text
-- WARNING: This technique could fail as gas documentation says it only
-- so we are hoping it does.
mkLayoutSection :: Int -> LMSection
mkLayoutSection n
-#if darwin_TARGET_OS
-- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which
-- doesn't support subsections. So we post process the assembly code, this
-- section specifier will be replaced with '.text' by the mangler.
- = Just (fsLit $ "__STRIP,__me" ++ show n)
+ = Just (fsLit $ infoSection ++ show n
+#if darwin_TARGET_OS
+ )
+#else
+ ++ "#")
+#endif
+
+-- | The section we are putting info tables and their entry code into
+infoSection :: String
+#if darwin_TARGET_OS
+infoSection = "__STRIP,__me"
#else
- = Just (fsLit $ ".text; .text " ++ show n ++ " #")
+infoSection = ".text; .text "
#endif
-- -----------------------------------------------------------------------------
-- | GHC LLVM Mangler
---
+--
-- This script processes the assembly produced by LLVM, rearranging the code
--- so that an info table appears before its corresponding function.
+-- so that an info table appears before its corresponding function. We also
+-- use it to fix up the stack alignment, which needs to be 16 byte aligned
+-- but always ends up off by 4 bytes because GHC sets it to the wrong starting
+-- value in the RTS.
+--
+-- We only need this for Mac OS X, other targets don't use it.
+--
+
module LlvmMangler ( llvmFixupAsm ) where
import Data.ByteString.Char8 ( ByteString )
import qualified Data.ByteString.Char8 as BS
-{-
- Configuration.
--}
+import LlvmCodeGen.Ppr ( infoSection, iTableSuf )
+
+
+{- Configuration. -}
newSection, oldSection, functionSuf, tableSuf, funDivider, eol :: ByteString
newSection = BS.pack "\n.text\n"
-oldSection = BS.pack "__STRIP,__me"
+oldSection = BS.pack infoSection
functionSuf = BS.pack "_info:"
-tableSuf = BS.pack "_info_itable:"
+tableSuf = BS.pack $ "_info" ++ iTableSuf ++ ":"
funDivider = BS.pack "\n\n"
eol = BS.pack "\n"
-eolPred :: Char -> Bool
+
+eolPred, dollarPred, commaPred :: Char -> Bool
eolPred = ((==) '\n')
+dollarPred = ((==) '$')
+commaPred = ((==) ',')
-- | Read in assembly file and process
llvmFixupAsm :: FilePath -> FilePath -> IO ()
any code before this function, then the info table, then the
function. It will return the remainder of the assembly code
to process.
-
+
We rely here on the fact that LLVM prints all global variables
at the end of the file, so an info table will always appear
after its function.
-
+
To try to help explain the string searches, here is some
assembly code that would be processed by this program, with
split markers placed in it like so, <split marker>:
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
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]
+ function = [before, eol, iheader', itable', eol, fheader', fun', eol]
remainder = bit' `BS.append` ait
in if BS.null al
- then do
+ then do
BS.appendFile f bl
return BS.empty
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 =
+ let -- fixup sub op
+ (a, b) = BS.breakSubstring (BS.pack ", %esp\n") fun
+ (a', num) = BS.breakEnd dollarPred a
+ num' = BS.pack $ show (read (BS.unpack num) + 4)
+ fix = a' `BS.append` num'
+ in if BS.null b
+ then nfun `BS.append` a
+ else fixupStack b (nfun `BS.append` fix)
+
+fixupStack fun nfun =
+ let -- fixup add ops
+ (a, b) = BS.breakSubstring (BS.pack "jmp") fun
+ -- We need to avoid processing jumps to labels, they are of the form:
+ -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
+ labelJump = BS.index b 4 == 'L'
+ (jmp, b') = BS.break eolPred b
+ (a', numx) = BS.breakEnd dollarPred a
+ (num, x) = BS.break commaPred numx
+ num' = BS.pack $ show (read (BS.unpack num) + 4)
+ fix = a' `BS.append` num' `BS.append` x `BS.append` jmp
+ in if BS.null b
+ then nfun `BS.append` a
+ else if labelJump
+ then fixupStack b' (nfun `BS.append` a `BS.append` jmp)
+ else fixupStack b' (nfun `BS.append` fix)
+
projects / ghc-hetmet.git / commitdiff