snailed
/
void-packages
2
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Activity
void-packages/srcpkgs/ghc/patches/llvm-3.6.patch

520 lines
20 KiB
Diff
Raw Normal View History

ghc: update to 7.10.1.
2015-03-30 11:29:03 +02:00
From 5d5abdca31cdb4db5303999778fa25c4a1371084 Mon Sep 17 00:00:00 2001
From: Ben Gamari <bgamari.foss@gmail.com>
Date: Mon, 9 Feb 2015 15:21:28 -0600
Subject: [PATCH 1/1] 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
---
compiler/llvmGen/Llvm/AbsSyn.hs | 13 ++++--
compiler/llvmGen/Llvm/MetaData.hs | 14 +++---
compiler/llvmGen/Llvm/PpLlvm.hs | 37 +++++++++------
compiler/llvmGen/LlvmCodeGen.hs | 7 +--
compiler/llvmGen/LlvmCodeGen/Base.hs | 26 ++---------
compiler/llvmGen/LlvmCodeGen/Data.hs | 2 +-
compiler/llvmGen/LlvmCodeGen/Ppr.hs | 90 ++++++++++--------------------------
compiler/llvmGen/LlvmMangler.hs | 49 ++------------------
8 files changed, 72 insertions(+), 166 deletions(-)
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 24d0856..b0eae2c 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -48,19 +48,22 @@ data LlvmModule = LlvmModule {
-- | An LLVM Function
data LlvmFunction = LlvmFunction {
-- | The signature of this declared function.
- funcDecl :: LlvmFunctionDecl,
+ funcDecl :: LlvmFunctionDecl,
-- | The functions arguments
- funcArgs :: [LMString],
+ funcArgs :: [LMString],
-- | The function attributes.
- funcAttrs :: [LlvmFuncAttr],
+ funcAttrs :: [LlvmFuncAttr],
-- | The section to put the function into,
- funcSect :: LMSection,
+ funcSect :: LMSection,
+
+ -- | Prefix data
+ funcPrefix :: Maybe LlvmStatic,
-- | The body of the functions.
- funcBody :: LlvmBlocks
+ funcBody :: LlvmBlocks
}
type LlvmFunctions = [LlvmFunction]
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 36efcd7..e1e63c9 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -20,12 +20,12 @@ import Outputable
-- information. They consist of metadata strings, metadata nodes, regular
-- LLVM values (both literals and references to global variables) and
-- metadata expressions (i.e., recursive data type). Some examples:
--- !{ metadata !"hello", metadata !0, i32 0 }
--- !{ metadata !1, metadata !{ i32 0 } }
+-- !{ !"hello", !0, i32 0 }
+-- !{ !1, !{ i32 0 } }
--
-- * Metadata nodes -- global metadata variables that attach a metadata
-- expression to a number. For example:
--- !0 = metadata !{ [<metadata expressions>] !}
+-- !0 = !{ [<metadata expressions>] !}
--
-- * Named metadata -- global metadata variables that attach a metadata nodes
-- to a name. Used ONLY to communicated module level information to LLVM
@@ -39,7 +39,7 @@ import Outputable
-- * Attach to instructions -- metadata can be attached to LLVM instructions
-- using a specific reference as follows:
-- %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.
-- Refer to LLVM documentation for which instructions take metadata and its
-- meaning.
@@ -63,10 +63,10 @@ data MetaExpr = MetaStr LMString
deriving (Eq)
instance Outputable MetaExpr where
- ppr (MetaStr s ) = text "metadata !\"" <> ftext s <> char '"'
- ppr (MetaNode n ) = text "metadata !" <> int n
+ ppr (MetaStr s ) = text "!\"" <> ftext s <> char '"'
+ ppr (MetaNode n ) = text "!" <> int n
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
-- instruction.
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 7307725..0b3deac 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -77,12 +77,12 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
Nothing -> ppr (pLower $ getVarType var)
-- Position of linkage is different for aliases.
- const_link = case c of
- Global -> ppr link <+> text "global"
- Constant -> ppr link <+> text "constant"
- Alias -> text "alias" <+> ppr link
+ const = case c of
+ Global -> text "global"
+ Constant -> text "constant"
+ Alias -> text "alias"
- in ppAssignment var $ const_link <+> rhs <> sect <> align
+ in ppAssignment var $ ppr link <+> const <+> rhs <> sect <> align
$+$ newLine
ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
@@ -117,11 +117,11 @@ ppLlvmMeta (MetaNamed n m)
-- | Print out an LLVM metadata value.
ppLlvmMetaExpr :: MetaExpr -> SDoc
-ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s)
-ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n
+ppLlvmMetaExpr (MetaStr s ) = text "!" <> doubleQuotes (ftext s)
+ppLlvmMetaExpr (MetaNode n ) = text "!" <> int n
ppLlvmMetaExpr (MetaVar v ) = ppr v
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.
@@ -130,15 +130,18 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
-- | Print out a function definition.
ppLlvmFunction :: LlvmFunction -> SDoc
-ppLlvmFunction (LlvmFunction dec args attrs sec body) =
- let attrDoc = ppSpaceJoin attrs
- secDoc = case sec of
+ppLlvmFunction fun =
+ let attrDoc = ppSpaceJoin (funcAttrs fun)
+ secDoc = case funcSect fun of
Just s' -> text "section" <+> (doubleQuotes $ ftext s')
Nothing -> empty
- in text "define" <+> ppLlvmFunctionHeader dec args
- <+> attrDoc <+> secDoc
+ prefixDoc = case funcPrefix fun of
+ Just v -> text "prefix" <+> ppr v
+ Nothing -> empty
+ in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
+ <+> attrDoc <+> secDoc <+> prefixDoc
$+$ lbrace
- $+$ ppLlvmBlocks body
+ $+$ ppLlvmBlocks (funcBody fun)
$+$ rbrace
$+$ newLine
$+$ newLine
@@ -269,7 +272,7 @@ ppCall ct fptr args attrs = case fptr of
where
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
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) <>
(case argTy of
VarArgs -> text ", ..."
@@ -280,6 +283,10 @@ ppCall ct fptr args attrs = case fptr of
<> fnty <+> ppName fptr <> lparen <+> ppValues
<+> 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 op left right =
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 6120a72..f0c184a 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -138,13 +138,8 @@ cmmLlvmGen cmm@CmmProc{} = do
-- generate llvm code from 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
- (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC
+ (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
-- Output, note down used variables
renderLlvm (vcat docs)
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 83b06a9..15918a3 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -24,11 +24,10 @@ module LlvmCodeGen.Base (
getMetaUniqueId,
setUniqMeta, getUniqMeta,
- freshSectionId,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
- llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
- llvmPtrBits, mkLlvmFunc, tysToParams,
+ llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+ llvmPtrBits, tysToParams,
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls,
@@ -133,15 +132,6 @@ llvmFunSig' live lbl link
(map (toParams . getVarType) (llvmFunArgs dflags live))
(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
llvmFunAlign :: DynFlags -> LMAlign
llvmFunAlign dflags = Just (wORD_SIZE dflags)
@@ -186,13 +176,13 @@ type LlvmVersion = Int
-- | The LLVM Version we assume if we don't know
defaultLlvmVersion :: LlvmVersion
-defaultLlvmVersion = 30
+defaultLlvmVersion = 36
minSupportLlvmVersion :: LlvmVersion
-minSupportLlvmVersion = 28
+minSupportLlvmVersion = 36
maxSupportLlvmVersion :: LlvmVersion
-maxSupportLlvmVersion = 35
+maxSupportLlvmVersion = 36
-- ----------------------------------------------------------------------------
-- * Environment Handling
@@ -203,7 +193,6 @@ data LlvmEnv = LlvmEnv
, envDynFlags :: DynFlags -- ^ Dynamic flags
, envOutput :: BufHandle -- ^ Output buffer
, envUniq :: UniqSupply -- ^ Supply of unique values
- , envNextSection :: Int -- ^ Supply of fresh section IDs
, envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
, envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
, envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
@@ -257,7 +246,6 @@ runLlvm dflags ver out us m = do
, envUniq = us
, envFreshMeta = 0
, envUniqMeta = emptyUFM
- , envNextSection = 1
}
-- | Get environment (internal)
@@ -362,10 +350,6 @@ setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta
getUniqMeta :: Unique -> LlvmM (Maybe Int)
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
--
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 90ce443..42f4dcd 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -4,7 +4,7 @@
--
module LlvmCodeGen.Data (
- genLlvmData
+ genLlvmData, genData
) where
#include "HsVersions.h"
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 5dd27ab..1a9373b 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -4,7 +4,7 @@
-- | Pretty print helpers for the LLVM Code generator.
--
module LlvmCodeGen.Ppr (
- pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection, iTableSuf
+ pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection
) where
#include "HsVersions.h"
@@ -96,28 +96,36 @@ pprLlvmData (globals, types) =
-- | Pretty print LLVM code
-pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
-pprLlvmCmmDecl _ (CmmData _ lmdata)
+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+pprLlvmCmmDecl (CmmData _ lmdata)
= return (vcat $ map pprLlvmData lmdata, [])
-pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks))
- = do (idoc, ivar) <- case mb_info of
- Nothing -> return (empty, [])
- Just (Statics info_lbl dat)
- -> pprInfoTable count info_lbl (Statics entry_lbl dat)
-
- 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'
+pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
+ = do let lbl = case mb_info of
+ Nothing -> entry_lbl
+ Just (Statics info_lbl _) -> info_lbl
+ link = if externallyVisibleCLabel lbl
then ExternallyVisible
else Internal
lmblocks = map (\(BasicBlock id stmts) ->
LlvmBlock (getUnique id) stmts) blks
- fun <- mkLlvmFunc live lbl' link sec' lmblocks
- let name = decName $ funcDecl fun
+ funDec <- llvmFunSig live lbl link
+ 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"
funcDecl' = (funcDecl fun) { decName = defName }
fun' = fun { funcDecl = funcDecl' }
@@ -138,55 +146,7 @@ pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks))
(Just $ LMBitc (LMStaticPointer defVar)
(LMPointer $ LMInt 8))
- return (ppLlvmGlobal alias $+$ idoc $+$ ppLlvmFunction fun', ivar)
-
-
--- | 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)
+ return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
-- | The section we are putting info tables and their entry code into, should
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 8652a89..267feb5 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -11,33 +11,24 @@ module LlvmMangler ( llvmFixupAsm ) where
import DynFlags ( DynFlags )
import ErrUtils ( showPass )
-import LlvmCodeGen.Ppr ( infoSection )
import Control.Exception
import Control.Monad ( when )
import qualified Data.ByteString.Char8 as B
-import Data.Char
import System.IO
-import Data.List ( sortBy )
-import Data.Function ( on )
-
#if x86_64_TARGET_ARCH
#define REWRITE_AVX
#endif
-- Magic Strings
-secStmt, infoSec, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
+secStmt, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
secStmt = B.pack "\t.section\t"
-infoSec = B.pack infoSection
newLine = B.pack "\n"
textStmt = B.pack "\t.text"
dataStmt = B.pack "\t.data"
syntaxUnified = B.pack "\t.syntax unified"
-infoLen :: Int
-infoLen = B.length infoSec
-
-- Search Predicates
isType :: B.ByteString -> Bool
isType = B.isPrefixOf (B.pack "\t.type")
@@ -53,7 +44,7 @@ llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
w <- openBinaryFile f2 WriteMode
ss <- readSections r w
hClose r
- let fixed = (map rewriteAVX . fixTables) ss
+ let fixed = map rewriteAVX ss
mapM_ (writeSection w) fixed
hClose w
return ()
@@ -91,11 +82,7 @@ readSections r w = go B.empty [] []
-- Decide whether to directly output the section or append it
-- to the list for resorting.
- let finishSection
- | infoSec `B.isInfixOf` hdr =
- cts `seq` return $ (hdr, cts):ss
- | otherwise =
- writeSection w (hdr, cts) >> return ss
+ let finishSection = writeSection w (hdr, cts) >> return ss
case e_l of
Right l | l == syntaxUnified
@@ -149,33 +136,3 @@ replace matchBS replaceBS = loop
(hd,tl) | B.null tl -> hd
| otherwise -> hd `B.append` replaceBS `B.append`
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"
--
1.9.1