ghc: update to 7.10.3b.
Disable LLVM for now as LLVM 3.7 isn't supported by GHC 7.10.3.
This commit is contained in:
parent
39febac51f
commit
64debff3db
|
@ -1,519 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,21 +1,23 @@
|
|||
# Template file for 'ghc'
|
||||
pkgname=ghc
|
||||
# Keep this synchronized with http://www.stackage.org/lts
|
||||
version=7.10.2
|
||||
version=7.10.3b
|
||||
revision=1
|
||||
wrksrc="ghc-${version%[!0-9]}"
|
||||
patch_args="-Np1"
|
||||
build_style=gnu-configure
|
||||
configure_args="--with-system-libffi"
|
||||
hostmakedepends="ghc-bin docbook-xsl libxslt llvm"
|
||||
makedepends="libffi-devel gmp-devel ncurses-devel llvm"
|
||||
hostmakedepends="automake ghc-bin docbook-xsl libxslt"
|
||||
makedepends="libffi-devel gmp-devel ncurses-devel"
|
||||
depends="perl gcc libffi-devel gmp-devel"
|
||||
short_desc="Glorious Haskell Compiler"
|
||||
maintainer="Christian Neukirchen <chneukirchen@gmail.com>"
|
||||
license="custom"
|
||||
homepage="http://www.haskell.org/ghc/"
|
||||
distfiles="http://www.haskell.org/ghc/dist/$version/$pkgname-$version-src.tar.xz"
|
||||
checksum=54cd73755b784d78e2f13d5eb161bfa38d3efee9e8a56f7eb6cd9f2d6e2615f5
|
||||
distfiles="http://www.haskell.org/ghc/dist/${version%[!0-9]}/${pkgname}-${version%[!0-9]}-src.tar.xz"
|
||||
checksum=cf90cedce1c28fd0e2b9e72fe8a938756668d18ea1fcc884a19f698658ac4fef
|
||||
nocross=yes # ask chris2 before wasting time trying to do that
|
||||
nopie=yes
|
||||
|
||||
pre_configure() {
|
||||
export CONF_CC_OPTS_STAGE0=$CFLAGS_FOR_BUILD
|
||||
|
@ -27,10 +29,12 @@ pre_configure() {
|
|||
export CONF_CPP_OPTS_STAGE0=$CPPFLAGS_FOR_BUILD
|
||||
export CONF_CPP_OPTS_STAGE1=$CPPFLAGS
|
||||
export CONF_CPP_OPTS_STAGE2=$CPPFLAGS
|
||||
|
||||
autoreconf -fi
|
||||
}
|
||||
|
||||
post_install() {
|
||||
sed -i 's#/usr/lib/ccache/bin/##g' ${DESTDIR}/usr/lib/ghc-${version}/settings
|
||||
sed -i 's#/usr/lib/ccache/bin/##g' ${DESTDIR}/usr/lib/ghc-${version%[!0-9]}/settings
|
||||
vlicense LICENSE
|
||||
}
|
||||
|
||||
|
|
Loading…
Reference in New Issue