Commit 5d5abdca authored by Ben Gamari's avatar Ben Gamari Committed by Austin Seipp

llvmGen: move to LLVM 3.6 exclusively

Summary:
Rework llvmGen to use LLVM 3.6 exclusively. The plans for the 7.12 release are to ship LLVM alongside GHC in the interests of user (and developer) sanity.

Along the way, refactor TNTC support to take advantage of the new `prefix` data support in LLVM 3.6. This allows us to drop the section-reordering component of the LLVM mangler.

Test Plan: Validate, look at emitted code

Reviewers: dterei, austin, scpmw

Reviewed By: austin

Subscribers: erikd, awson, spacekitteh, thomie, carter

Differential Revision: https://phabricator.haskell.org/D530

GHC Trac Issues: #10074
parent d5a80dbe
...@@ -48,19 +48,22 @@ data LlvmModule = LlvmModule { ...@@ -48,19 +48,22 @@ data LlvmModule = LlvmModule {
-- | An LLVM Function -- | An LLVM Function
data LlvmFunction = LlvmFunction { data LlvmFunction = LlvmFunction {
-- | The signature of this declared function. -- | The signature of this declared function.
funcDecl :: LlvmFunctionDecl, funcDecl :: LlvmFunctionDecl,
-- | The functions arguments -- | The functions arguments
funcArgs :: [LMString], funcArgs :: [LMString],
-- | The function attributes. -- | The function attributes.
funcAttrs :: [LlvmFuncAttr], funcAttrs :: [LlvmFuncAttr],
-- | The section to put the function into, -- | The section to put the function into,
funcSect :: LMSection, funcSect :: LMSection,
-- | Prefix data
funcPrefix :: Maybe LlvmStatic,
-- | The body of the functions. -- | The body of the functions.
funcBody :: LlvmBlocks funcBody :: LlvmBlocks
} }
type LlvmFunctions = [LlvmFunction] type LlvmFunctions = [LlvmFunction]
......
...@@ -20,12 +20,12 @@ import Outputable ...@@ -20,12 +20,12 @@ import Outputable
-- information. They consist of metadata strings, metadata nodes, regular -- information. They consist of metadata strings, metadata nodes, regular
-- LLVM values (both literals and references to global variables) and -- LLVM values (both literals and references to global variables) and
-- metadata expressions (i.e., recursive data type). Some examples: -- metadata expressions (i.e., recursive data type). Some examples:
-- !{ metadata !"hello", metadata !0, i32 0 } -- !{ !"hello", !0, i32 0 }
-- !{ metadata !1, metadata !{ i32 0 } } -- !{ !1, !{ i32 0 } }
-- --
-- * Metadata nodes -- global metadata variables that attach a metadata -- * Metadata nodes -- global metadata variables that attach a metadata
-- expression to a number. For example: -- expression to a number. For example:
-- !0 = metadata !{ [<metadata expressions>] !} -- !0 = !{ [<metadata expressions>] !}
-- --
-- * Named metadata -- global metadata variables that attach a metadata nodes -- * Named metadata -- global metadata variables that attach a metadata nodes
-- to a name. Used ONLY to communicated module level information to LLVM -- to a name. Used ONLY to communicated module level information to LLVM
...@@ -39,7 +39,7 @@ import Outputable ...@@ -39,7 +39,7 @@ import Outputable
-- * Attach to instructions -- metadata can be attached to LLVM instructions -- * Attach to instructions -- metadata can be attached to LLVM instructions
-- using a specific reference as follows: -- using a specific reference as follows:
-- %l = load i32* @glob, !nontemporal !10 -- %l = load i32* @glob, !nontemporal !10
-- %m = load i32* @glob, !nontemporal !{ i32 0, metadata !{ i32 0 } } -- %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
-- Only metadata nodes or expressions can be attached, named metadata cannot. -- Only metadata nodes or expressions can be attached, named metadata cannot.
-- Refer to LLVM documentation for which instructions take metadata and its -- Refer to LLVM documentation for which instructions take metadata and its
-- meaning. -- meaning.
...@@ -63,10 +63,10 @@ data MetaExpr = MetaStr LMString ...@@ -63,10 +63,10 @@ data MetaExpr = MetaStr LMString
deriving (Eq) deriving (Eq)
instance Outputable MetaExpr where instance Outputable MetaExpr where
ppr (MetaStr s ) = text "metadata !\"" <> ftext s <> char '"' ppr (MetaStr s ) = text "!\"" <> ftext s <> char '"'
ppr (MetaNode n ) = text "metadata !" <> int n ppr (MetaNode n ) = text "!" <> int n
ppr (MetaVar v ) = ppr v ppr (MetaVar v ) = ppr v
ppr (MetaStruct es) = text "metadata !{ " <> ppCommaJoin es <> char '}' ppr (MetaStruct es) = text "!{ " <> ppCommaJoin es <> char '}'
-- | Associates some metadata with a specific label for attaching to an -- | Associates some metadata with a specific label for attaching to an
-- instruction. -- instruction.
......
...@@ -77,12 +77,12 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = ...@@ -77,12 +77,12 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
Nothing -> ppr (pLower $ getVarType var) Nothing -> ppr (pLower $ getVarType var)
-- Position of linkage is different for aliases. -- Position of linkage is different for aliases.
const_link = case c of const = case c of
Global -> ppr link <+> text "global" Global -> text "global"
Constant -> ppr link <+> text "constant" Constant -> text "constant"
Alias -> text "alias" <+> ppr link Alias -> text "alias"
in ppAssignment var $ const_link <+> rhs <> sect <> align in ppAssignment var $ ppr link <+> const <+> rhs <> sect <> align
$+$ newLine $+$ newLine
ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags -> ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
...@@ -117,11 +117,11 @@ ppLlvmMeta (MetaNamed n m) ...@@ -117,11 +117,11 @@ ppLlvmMeta (MetaNamed n m)
-- | Print out an LLVM metadata value. -- | Print out an LLVM metadata value.
ppLlvmMetaExpr :: MetaExpr -> SDoc ppLlvmMetaExpr :: MetaExpr -> SDoc
ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s) ppLlvmMetaExpr (MetaStr s ) = text "!" <> doubleQuotes (ftext s)
ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n ppLlvmMetaExpr (MetaNode n ) = text "!" <> int n
ppLlvmMetaExpr (MetaVar v ) = ppr v ppLlvmMetaExpr (MetaVar v ) = ppr v
ppLlvmMetaExpr (MetaStruct es) = ppLlvmMetaExpr (MetaStruct es) =
text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}' text "!{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
-- | Print out a list of function definitions. -- | Print out a list of function definitions.
...@@ -130,15 +130,18 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs ...@@ -130,15 +130,18 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
-- | Print out a function definition. -- | Print out a function definition.
ppLlvmFunction :: LlvmFunction -> SDoc ppLlvmFunction :: LlvmFunction -> SDoc
ppLlvmFunction (LlvmFunction dec args attrs sec body) = ppLlvmFunction fun =
let attrDoc = ppSpaceJoin attrs let attrDoc = ppSpaceJoin (funcAttrs fun)
secDoc = case sec of secDoc = case funcSect fun of
Just s' -> text "section" <+> (doubleQuotes $ ftext s') Just s' -> text "section" <+> (doubleQuotes $ ftext s')
Nothing -> empty Nothing -> empty
in text "define" <+> ppLlvmFunctionHeader dec args prefixDoc = case funcPrefix fun of
<+> attrDoc <+> secDoc Just v -> text "prefix" <+> ppr v
Nothing -> empty
in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
<+> attrDoc <+> secDoc <+> prefixDoc
$+$ lbrace $+$ lbrace
$+$ ppLlvmBlocks body $+$ ppLlvmBlocks (funcBody fun)
$+$ rbrace $+$ rbrace
$+$ newLine $+$ newLine
$+$ newLine $+$ newLine
...@@ -269,7 +272,7 @@ ppCall ct fptr args attrs = case fptr of ...@@ -269,7 +272,7 @@ ppCall ct fptr args attrs = case fptr of
where where
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
let tc = if ct == TailCall then text "tail " else empty let tc = if ct == TailCall then text "tail " else empty
ppValues = ppCommaJoin args ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
ppArgTy = (ppCommaJoin $ map fst params) <> ppArgTy = (ppCommaJoin $ map fst params) <>
(case argTy of (case argTy of
VarArgs -> text ", ..." VarArgs -> text ", ..."
...@@ -280,6 +283,10 @@ ppCall ct fptr args attrs = case fptr of ...@@ -280,6 +283,10 @@ ppCall ct fptr args attrs = case fptr of
<> fnty <+> ppName fptr <> lparen <+> ppValues <> fnty <+> ppName fptr <> lparen <+> ppValues
<+> rparen <+> attrDoc <+> rparen <+> attrDoc
-- Metadata needs to be marked as having the `metadata` type when used
-- in a call argument
ppCallMetaExpr (MetaVar v) = ppr v
ppCallMetaExpr v = text "metadata" <+> ppr v
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op left right = ppMachOp op left right =
......
...@@ -138,13 +138,8 @@ cmmLlvmGen cmm@CmmProc{} = do ...@@ -138,13 +138,8 @@ cmmLlvmGen cmm@CmmProc{} = do
-- generate llvm code from cmm -- generate llvm code from cmm
llvmBC <- withClearVars $ genLlvmProc fixed_cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm
-- allocate IDs for info table and code, so the mangler can later
-- make sure they end up next to each other.
itableSection <- freshSectionId
_codeSection <- freshSectionId
-- pretty print -- pretty print
(docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
-- Output, note down used variables -- Output, note down used variables
renderLlvm (vcat docs) renderLlvm (vcat docs)
......
...@@ -24,11 +24,10 @@ module LlvmCodeGen.Base ( ...@@ -24,11 +24,10 @@ module LlvmCodeGen.Base (
getMetaUniqueId, getMetaUniqueId,
setUniqMeta, getUniqMeta, setUniqMeta, getUniqMeta,
freshSectionId,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, mkLlvmFunc, tysToParams, llvmPtrBits, tysToParams,
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls, getGlobalPtr, generateExternDecls,
...@@ -133,15 +132,6 @@ llvmFunSig' live lbl link ...@@ -133,15 +132,6 @@ llvmFunSig' live lbl link
(map (toParams . getVarType) (llvmFunArgs dflags live)) (map (toParams . getVarType) (llvmFunArgs dflags live))
(llvmFunAlign dflags) (llvmFunAlign dflags)
-- | Create a Haskell function in LLVM.
mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmM LlvmFunction
mkLlvmFunc live lbl link sec blks
= do funDec <- llvmFunSig live lbl link
dflags <- getDynFlags
let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live)
return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions -- | Alignment to use for functions
llvmFunAlign :: DynFlags -> LMAlign llvmFunAlign :: DynFlags -> LMAlign
llvmFunAlign dflags = Just (wORD_SIZE dflags) llvmFunAlign dflags = Just (wORD_SIZE dflags)
...@@ -186,13 +176,13 @@ type LlvmVersion = Int ...@@ -186,13 +176,13 @@ type LlvmVersion = Int
-- | The LLVM Version we assume if we don't know -- | The LLVM Version we assume if we don't know
defaultLlvmVersion :: LlvmVersion defaultLlvmVersion :: LlvmVersion
defaultLlvmVersion = 30 defaultLlvmVersion = 36
minSupportLlvmVersion :: LlvmVersion minSupportLlvmVersion :: LlvmVersion
minSupportLlvmVersion = 28 minSupportLlvmVersion = 36
maxSupportLlvmVersion :: LlvmVersion maxSupportLlvmVersion :: LlvmVersion
maxSupportLlvmVersion = 35 maxSupportLlvmVersion = 36
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- * Environment Handling -- * Environment Handling
...@@ -203,7 +193,6 @@ data LlvmEnv = LlvmEnv ...@@ -203,7 +193,6 @@ data LlvmEnv = LlvmEnv
, envDynFlags :: DynFlags -- ^ Dynamic flags , envDynFlags :: DynFlags -- ^ Dynamic flags
, envOutput :: BufHandle -- ^ Output buffer , envOutput :: BufHandle -- ^ Output buffer
, envUniq :: UniqSupply -- ^ Supply of unique values , envUniq :: UniqSupply -- ^ Supply of unique values
, envNextSection :: Int -- ^ Supply of fresh section IDs
, envFreshMeta :: Int -- ^ Supply of fresh metadata IDs , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
, envUniqMeta :: UniqFM Int -- ^ Global metadata nodes , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
, envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
...@@ -257,7 +246,6 @@ runLlvm dflags ver out us m = do ...@@ -257,7 +246,6 @@ runLlvm dflags ver out us m = do
, envUniq = us , envUniq = us
, envFreshMeta = 0 , envFreshMeta = 0
, envUniqMeta = emptyUFM , envUniqMeta = emptyUFM
, envNextSection = 1
} }
-- | Get environment (internal) -- | Get environment (internal)
...@@ -362,10 +350,6 @@ setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta ...@@ -362,10 +350,6 @@ setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta
getUniqMeta :: Unique -> LlvmM (Maybe Int) getUniqMeta :: Unique -> LlvmM (Maybe Int)
getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
-- | Returns a fresh section ID
freshSectionId :: LlvmM Int
freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1})
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- * Internal functions -- * Internal functions
-- --
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
-- --
module LlvmCodeGen.Data ( module LlvmCodeGen.Data (
genLlvmData genLlvmData, genData
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
-- | Pretty print helpers for the LLVM Code generator. -- | Pretty print helpers for the LLVM Code generator.
-- --
module LlvmCodeGen.Ppr ( module LlvmCodeGen.Ppr (
pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection, iTableSuf pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -96,28 +96,36 @@ pprLlvmData (globals, types) = ...@@ -96,28 +96,36 @@ pprLlvmData (globals, types) =
-- | Pretty print LLVM code -- | Pretty print LLVM code
pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl _ (CmmData _ lmdata) pprLlvmCmmDecl (CmmData _ lmdata)
= return (vcat $ map pprLlvmData lmdata, []) = return (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks)) pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
= do (idoc, ivar) <- case mb_info of = do let lbl = case mb_info of
Nothing -> return (empty, []) Nothing -> entry_lbl
Just (Statics info_lbl dat) Just (Statics info_lbl _) -> info_lbl
-> pprInfoTable count info_lbl (Statics entry_lbl dat) link = if externallyVisibleCLabel lbl
let sec = mkLayoutSection (count + 1)
(lbl',sec') = case mb_info of
Nothing -> (entry_lbl, Nothing)
Just (Statics info_lbl _) -> (info_lbl, sec)
link = if externallyVisibleCLabel lbl'
then ExternallyVisible then ExternallyVisible
else Internal else Internal
lmblocks = map (\(BasicBlock id stmts) -> lmblocks = map (\(BasicBlock id stmts) ->
LlvmBlock (getUnique id) stmts) blks LlvmBlock (getUnique id) stmts) blks
fun <- mkLlvmFunc live lbl' link sec' lmblocks funDec <- llvmFunSig live lbl link
let name = decName $ funcDecl fun dflags <- getDynFlags
let buildArg = fsLit . showSDoc dflags . ppPlainName
funArgs = map buildArg (llvmFunArgs dflags live)
-- generate the info table
prefix <- case mb_info of
Nothing -> return Nothing
Just (Statics _ statics) -> do
infoStatics <- mapM genData statics
let infoTy = LMStruct $ map getStatType infoStatics
return $ Just $ LMStaticStruc infoStatics infoTy
let fun = LlvmFunction funDec funArgs llvmStdFunAttrs Nothing
prefix lmblocks
name = decName $ funcDecl fun
defName = name `appendFS` fsLit "$def" defName = name `appendFS` fsLit "$def"
funcDecl' = (funcDecl fun) { decName = defName } funcDecl' = (funcDecl fun) { decName = defName }
fun' = fun { funcDecl = funcDecl' } fun' = fun { funcDecl = funcDecl' }
...@@ -138,55 +146,7 @@ pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks)) ...@@ -138,55 +146,7 @@ pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks))
(Just $ LMBitc (LMStaticPointer defVar) (Just $ LMBitc (LMStaticPointer defVar)
(LMPointer $ LMInt 8)) (LMPointer $ LMInt 8))
return (ppLlvmGlobal alias $+$ idoc $+$ ppLlvmFunction fun', ivar) return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
-- | Pretty print CmmStatic
pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar])
pprInfoTable count info_lbl stat
= do (ldata, ltypes) <- genLlvmData (Text, stat)
dflags <- getDynFlags
platform <- getLlvmPlatform
let setSection :: LMGlobal -> LlvmM (LMGlobal, [LlvmVar])
setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do
lbl <- strCLabel_llvm info_lbl
let sec = mkLayoutSection count
ilabel = lbl `appendFS` fsLit iTableSuf
gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c
-- See Note [Subsections Via Symbols]
v = if (platformHasSubsectionsViaSymbols platform
&& l == ExternallyVisible)
|| l == Internal
then [gv]
else []
funInsert ilabel ty
return (LMGlobal gv d, v)
setSection v = return (v,[])
(ldata', llvmUsed) <- unzip `fmap` mapM setSection ldata
ldata'' <- mapM aliasify ldata'
let modUsedLabel (LMGlobalVar name ty link sect align const) =
LMGlobalVar (name `appendFS` fsLit "$def") ty link sect align const
modUsedLabel v = v
llvmUsed' = map modUsedLabel $ concat llvmUsed
return (pprLlvmData (concat 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 a specially crafted section declaration that encodes the order this
-- section should be in the final object code.
--
-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses
-- this section declaration to do its processing.
mkLayoutSection :: Int -> LMSection
mkLayoutSection n
= Just (fsLit $ infoSection ++ show n)
-- | The section we are putting info tables and their entry code into, should -- | The section we are putting info tables and their entry code into, should
......
...@@ -11,33 +11,24 @@ module LlvmMangler ( llvmFixupAsm ) where ...@@ -11,33 +11,24 @@ module LlvmMangler ( llvmFixupAsm ) where
import DynFlags ( DynFlags ) import DynFlags ( DynFlags )
import ErrUtils ( showPass ) import ErrUtils ( showPass )
import LlvmCodeGen.Ppr ( infoSection )
import Control.Exception import Control.Exception
import Control.Monad ( when ) import Control.Monad ( when )
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Char
import System.IO import System.IO
import Data.List ( sortBy )
import Data.Function ( on )
#if x86_64_TARGET_ARCH #if x86_64_TARGET_ARCH
#define REWRITE_AVX #define REWRITE_AVX
#endif #endif
-- Magic Strings -- Magic Strings
secStmt, infoSec, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString secStmt, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
secStmt = B.pack "\t.section\t" secStmt = B.pack "\t.section\t"
infoSec = B.pack infoSection
newLine = B.pack "\n" newLine = B.pack "\n"
textStmt = B.pack "\t.text" textStmt = B.pack "\t.text"
dataStmt = B.pack "\t.data" dataStmt = B.pack "\t.data"
syntaxUnified = B.pack "\t.syntax unified" syntaxUnified = B.pack "\t.syntax unified"
infoLen :: Int
infoLen = B.length infoSec
-- Search Predicates -- Search Predicates
isType :: B.ByteString -> Bool isType :: B.ByteString -> Bool
isType = B.isPrefixOf (B.pack "\t.type") isType = B.isPrefixOf (B.pack "\t.type")
...@@ -53,7 +44,7 @@ llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do ...@@ -53,7 +44,7 @@ llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
w <- openBinaryFile f2 WriteMode w <- openBinaryFile f2 WriteMode
ss <- readSections r w ss <- readSections r w
hClose r hClose r
let fixed = (map rewriteAVX . fixTables) ss let fixed = map rewriteAVX ss
mapM_ (writeSection w) fixed mapM_ (writeSection w) fixed
hClose w hClose w
return () return ()
...@@ -91,11 +82,7 @@ readSections r w = go B.empty [] [] ...@@ -91,11 +82,7 @@ readSections r w = go B.empty [] []
-- Decide whether to directly output the section or append it -- Decide whether to directly output the section or append it
-- to the list for resorting. -- to the list for resorting.
let finishSection let finishSection = writeSection w (hdr, cts) >> return ss
| infoSec `B.isInfixOf` hdr =
cts `seq` return $ (hdr, cts):ss
| otherwise =
writeSection w (hdr, cts) >> return ss
case e_l of case e_l of
Right l | l == syntaxUnified Right l | l == syntaxUnified
...@@ -149,33 +136,3 @@ replace matchBS replaceBS = loop ...@@ -149,33 +136,3 @@ replace matchBS replaceBS = loop
(hd,tl) | B.null tl -> hd (hd,tl) | B.null tl -> hd
| otherwise -> hd `B.append` replaceBS `B.append` | otherwise -> hd `B.append` replaceBS `B.append`
loop (B.drop (B.length matchBS) tl) loop (B.drop (B.length matchBS) tl)
-- | Reorder and convert sections so info tables end up next to the
-- code. Also does stack fixups.
fixTables :: [Section] -> [Section]
fixTables ss = map strip sorted
where
-- Resort sections: We only assign a non-zero number to all
-- sections having the "STRIP ME" marker. As sortBy is stable,
-- this will cause all these sections to be appended to the end of
-- the file in the order given by the indexes.
extractIx hdr
| B.null a = 0
| otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a)
where (_,a) = B.breakSubstring infoSec hdr
indexed = zip (map (extractIx . fst) ss) ss
sorted = map snd $ sortBy (compare `on` fst) indexed
-- Turn all the "STRIP ME" sections into normal text sections, as
-- they are in the right place now.
strip (hdr, cts)
| infoSec `B.isInfixOf` hdr = (textStmt, cts)
| otherwise = (hdr, cts)
-- | 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"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment