summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--aclocal.m48
-rw-r--r--compiler/llvmGen/Llvm.hs6
-rw-r--r--compiler/llvmGen/Llvm/AbsSyn.hs15
-rw-r--r--compiler/llvmGen/Llvm/PpLlvm.hs88
-rw-r--r--compiler/llvmGen/Llvm/Types.hs39
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs57
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs16
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Regs.hs45
-rw-r--r--distrib/MacOS/GHC.xcodeproj/project.pbxproj2
-rw-r--r--ghc.mk9
-rw-r--r--rts/Linker.c96
11 files changed, 303 insertions, 78 deletions
diff --git a/aclocal.m4 b/aclocal.m4
index c54918e4ae..1c89e0d02a 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -1989,10 +1989,12 @@ AC_DEFUN([XCODE_VERSION],[
# Finds where gcc is
AC_DEFUN([FIND_GCC],[
if test "$TargetOS_CPP" = "darwin" &&
- test "$XCodeVersion1" -ge 4
+ test "$XCodeVersion1" -eq 4 &&
+ test "$XCodeVersion2" -lt 2
then
- # From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy
- # backend (instead of the LLVM backend)
+ # In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather
+ # than the LLVM backend). We prefer the legacy gcc, but in
+ # Xcode 4.2 'gcc-4.2' was removed.
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2])
else
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index aec492e151..b15b6f261d 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -34,6 +34,9 @@ module Llvm (
-- ** Some basic types
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
+ -- ** Metadata types
+ LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData,
+
-- ** Operations on the type system.
isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower,
@@ -42,7 +45,8 @@ module Llvm (
-- * Pretty Printing
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
- ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc
+ ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
+ llvmSDoc
) where
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 93bc62c91f..a28734b152 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -31,6 +31,9 @@ data LlvmModule = LlvmModule {
-- | LLVM Alias type definitions.
modAliases :: [LlvmAlias],
+ -- | LLVM meta data.
+ modMeta :: [LlvmMeta],
+
-- | Global variables to include in the module.
modGlobals :: [LMGlobal],
@@ -138,8 +141,15 @@ data LlvmStatement
-}
| Nop
+ {- |
+ A LLVM statement with metadata attached to it.
+ -}
+ | MetaStmt [MetaData] LlvmStatement
+
deriving (Show, Eq)
+type MetaData = (LMString, LlvmMetaUnamed)
+
-- | Llvm Expressions
data LlvmExpression
@@ -229,5 +239,10 @@ data LlvmExpression
-}
| Asm LMString LMString LlvmType [LlvmVar] Bool Bool
+ {- |
+ A LLVM expression with metadata attached to it.
+ -}
+ | MetaExpr [MetaData] LlvmExpression
+
deriving (Show, Eq)
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index b5c3ba8f7e..2945777f96 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -10,8 +10,10 @@ module Llvm.PpLlvm (
ppLlvmComment,
ppLlvmGlobals,
ppLlvmGlobal,
- ppLlvmAlias,
ppLlvmAliases,
+ ppLlvmAlias,
+ ppLlvmMetas,
+ ppLlvmMeta,
ppLlvmFunctionDecls,
ppLlvmFunctionDecl,
ppLlvmFunctions,
@@ -38,9 +40,10 @@ import Unique
-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> Doc
-ppLlvmModule (LlvmModule comments aliases globals decls funcs)
+ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
+ $+$ ppLlvmMetas meta $+$ newLine
$+$ ppLlvmGlobals globals $+$ newLine
$+$ ppLlvmFunctionDecls decls $+$ newLine
$+$ ppLlvmFunctions funcs
@@ -88,7 +91,32 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> Doc
ppLlvmAlias (name, ty)
- = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty $+$ newLine
+ = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
+
+
+-- | Print out a list of LLVM metadata.
+ppLlvmMetas :: [LlvmMeta] -> Doc
+ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
+
+-- | Print out an LLVM metadata definition.
+ppLlvmMeta :: LlvmMeta -> Doc
+ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas)
+ = exclamation <> int u <> text " = metadata !{" <>
+ hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}"
+
+ppLlvmMeta (MetaNamed n metas)
+ = exclamation <> ftext n <> text " = !{" <>
+ hcat (intersperse comma $ map pprNode munq) <> text "}"
+ where
+ munq = map (\(LMMetaUnamed u) -> u) metas
+ pprNode n = exclamation <> int n
+
+-- | Print out an LLVM metadata value.
+ppLlvmMetaVal :: LlvmMetaVal -> Doc
+ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s)
+ppLlvmMetaVal (MetaVar v) = texts v
+ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
+ = text "metadata !" <> int u
-- | Print out a list of function definitions.
@@ -168,29 +196,33 @@ ppLlvmBlock (LlvmBlock blockId stmts)
Just id2' -> go id2' rest
Nothing -> empty
in ppLlvmBlockLabel id
- $+$ nest 4 (vcat $ map ppLlvmStatement block)
+ $+$ (vcat $ map ppLlvmStatement block)
$+$ newLine
$+$ ppRest
+-- | Print out an LLVM block label.
+ppLlvmBlockLabel :: LlvmBlockId -> Doc
+ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
+
+
-- | Print out an LLVM statement.
ppLlvmStatement :: LlvmStatement -> Doc
-ppLlvmStatement stmt
- = case stmt of
- Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr)
- Branch target -> ppBranch target
- BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF
- Comment comments -> ppLlvmComments comments
+ppLlvmStatement stmt =
+ let ind = (text " " <>)
+ in case stmt of
+ Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr)
+ Branch target -> ind $ ppBranch target
+ BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF
+ Comment comments -> ind $ ppLlvmComments comments
MkLabel label -> ppLlvmBlockLabel label
- Store value ptr -> ppStore value ptr
- Switch scrut def tgs -> ppSwitch scrut def tgs
- Return result -> ppReturn result
- Expr expr -> ppLlvmExpression expr
- Unreachable -> text "unreachable"
+ Store value ptr -> ind $ ppStore value ptr
+ Switch scrut def tgs -> ind $ ppSwitch scrut def tgs
+ Return result -> ind $ ppReturn result
+ Expr expr -> ind $ ppLlvmExpression expr
+ Unreachable -> ind $ text "unreachable"
Nop -> empty
+ MetaStmt meta s -> ppMetaStatement meta s
--- | Print out an LLVM block label.
-ppLlvmBlockLabel :: LlvmBlockId -> Doc
-ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
-- | Print out an LLVM expression.
ppLlvmExpression :: LlvmExpression -> Doc
@@ -206,6 +238,7 @@ ppLlvmExpression expr
Malloc tp amount -> ppMalloc tp amount
Phi tp precessors -> ppPhi tp precessors
Asm asm c ty v se sk -> ppAsm asm c ty v se sk
+ MetaExpr meta expr -> ppMetaExpr meta expr
--------------------------------------------------------------------------------
@@ -341,6 +374,21 @@ ppAsm asm constraints rty vars sideeffect alignstack =
<+> cons <> vars'
+ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc
+ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
+
+
+ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc
+ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
+
+
+ppMetas :: [MetaData] -> Doc
+ppMetas meta = hcat $ map ppMeta meta
+ where
+ ppMeta (name, (LMMetaUnamed n))
+ = comma <+> exclamation <> ftext name <+> exclamation <> int n
+
+
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
@@ -362,3 +410,7 @@ texts = (text . show)
newLine :: Doc
newLine = text ""
+-- | Exclamation point.
+exclamation :: Doc
+exclamation = text "!"
+
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 101342606d..07e53fb731 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -70,12 +70,49 @@ instance Show LlvmType where
show (LMAlias (s,_)) = "%" ++ unpackFS s
+-- | LLVM metadata values. Used for representing debug and optimization
+-- information.
+data LlvmMetaVal
+ -- | Metadata string
+ = MetaStr LMString
+ -- | Metadata node
+ | MetaNode LlvmMetaUnamed
+ -- | Normal value type as metadata
+ | MetaVar LlvmVar
+ deriving (Eq)
+
+-- | LLVM metadata nodes.
+data LlvmMeta
+ -- | Unamed metadata
+ = MetaUnamed LlvmMetaUnamed [LlvmMetaVal]
+ -- | Named metadata
+ | MetaNamed LMString [LlvmMetaUnamed]
+ deriving (Eq)
+
+-- | Unamed metadata variable.
+newtype LlvmMetaUnamed = LMMetaUnamed Int
+
+instance Eq LlvmMetaUnamed where
+ (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m
+
+instance Show LlvmMetaVal where
+ show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\""
+ show (MetaNode n) = "metadata " ++ show n
+ show (MetaVar v) = show v
+
+instance Show LlvmMetaUnamed where
+ show (LMMetaUnamed u) = "!" ++ show u
+
+instance Show LlvmMeta where
+ show (MetaUnamed m _) = show m
+ show (MetaNamed m _) = "!" ++ unpackFS m
+
-- | An LLVM section definition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString
type LMAlign = Maybe Int
type LMConst = Bool -- ^ is a variable constant or not
--- | Llvm Variables
+-- | LLVM Variables
data LlvmVar
-- | Variables with a global scope.
= LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 07ccbb1348..4309dcdae1 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -550,7 +550,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [
= genStore_fast env addr r (negate $ fromInteger n) val
-- generic case
-genStore env addr val = genStore_slow env addr val
+genStore env addr val = genStore_slow env addr val [top]
-- | CmmStore operation
-- This is a special case for storing to a global register pointer
@@ -558,8 +558,9 @@ genStore env addr val = genStore_slow env addr val
genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
-> UniqSM StmtData
genStore_fast env addr r n val
- = let gr = lmGlobalRegVar r
- grt = (pLower . getVarType) gr
+ = let gr = lmGlobalRegVar r
+ meta = [getTBAA r]
+ grt = (pLower . getVarType) gr
(ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
in case isPointer grt && rem == 0 of
True -> do
@@ -570,7 +571,7 @@ genStore_fast env addr r n val
case pLower grt == getVarType vval of
-- were fine
True -> do
- let s3 = Store vval ptr
+ let s3 = MetaStmt meta $ Store vval ptr
return (env', stmts `snocOL` s1 `snocOL` s2
`snocOL` s3, top)
@@ -578,19 +579,19 @@ genStore_fast env addr r n val
False -> do
let ty = (pLift . getVarType) vval
(ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
- let s4 = Store vval ptr'
+ let s4 = MetaStmt meta $ Store vval ptr'
return (env', stmts `snocOL` s1 `snocOL` s2
`snocOL` s3 `snocOL` s4, top)
-- If its a bit type then we use the slow method since
-- we can't avoid casting anyway.
- False -> genStore_slow env addr val
+ False -> genStore_slow env addr val meta
-- | CmmStore operation
-- Generic case. Uses casts and pointer arithmetic if needed.
-genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
-genStore_slow env addr val = do
+genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData
+genStore_slow env addr val meta = do
(env1, vaddr, stmts1, top1) <- exprToVar env addr
(env2, vval, stmts2, top2) <- exprToVar env1 val
@@ -599,17 +600,17 @@ genStore_slow env addr val = do
-- sometimes we need to cast an int to a pointer before storing
LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
- let s2 = Store v vaddr
+ let s2 = MetaStmt meta $ Store v vaddr
return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
LMPointer _ -> do
- let s1 = Store vval vaddr
+ let s1 = MetaStmt meta $ Store vval vaddr
return (env2, stmts `snocOL` s1, top1 ++ top2)
i@(LMInt _) | i == llvmWord -> do
let vty = pLift $ getVarType vval
(vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
- let s2 = Store vval vptr
+ let s2 = MetaStmt meta $ Store vval vptr
return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
other ->
@@ -841,8 +842,8 @@ genMachOp env opt op e = genMachOp_slow env opt op e
genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
-> UniqSM ExprData
genMachOp_fast env opt op r n e
- = let gr = lmGlobalRegVar r
- grt = (pLower . getVarType) gr
+ = let gr = lmGlobalRegVar r
+ grt = (pLower . getVarType) gr
(ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
in case isPointer grt && rem == 0 of
True -> do
@@ -1031,7 +1032,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [
= genLoad_fast env e r (negate $ fromInteger n) ty
-- generic case
-genLoad env e ty = genLoad_slow env e ty
+genLoad env e ty = genLoad_slow env e ty [top]
-- | Handle CmmLoad expression.
-- This is a special case for loading from a global register pointer
@@ -1039,9 +1040,10 @@ genLoad env e ty = genLoad_slow env e ty
genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
-> UniqSM ExprData
genLoad_fast env e r n ty =
- let gr = lmGlobalRegVar r
- grt = (pLower . getVarType) gr
- ty' = cmmToLlvmType ty
+ let gr = lmGlobalRegVar r
+ meta = [getTBAA r]
+ grt = (pLower . getVarType) gr
+ ty' = cmmToLlvmType ty
(ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
in case isPointer grt && rem == 0 of
True -> do
@@ -1051,7 +1053,7 @@ genLoad_fast env e r n ty =
case grt == ty' of
-- were fine
True -> do
- (var, s3) <- doExpr ty' $ Load ptr
+ (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr)
return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
[])
@@ -1059,29 +1061,31 @@ genLoad_fast env e r n ty =
False -> do
let pty = pLift ty'
(ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
- (var, s4) <- doExpr ty' $ Load ptr'
+ (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr')
return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
`snocOL` s4, [])
-- If its a bit type then we use the slow method since
-- we can't avoid casting anyway.
- False -> genLoad_slow env e ty
+ False -> genLoad_slow env e ty meta
-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
-genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
-genLoad_slow env e ty = do
+genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData
+genLoad_slow env e ty meta = do
(env', iptr, stmts, tops) <- exprToVar env e
case getVarType iptr of
LMPointer _ -> do
- (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
+ (dvar, load) <- doExpr (cmmToLlvmType ty)
+ (MetaExpr meta $ Load iptr)
return (env', dvar, stmts `snocOL` load, tops)
i@(LMInt _) | i == llvmWord -> do
let pty = LMPointer $ cmmToLlvmType ty
(ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
- (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
+ (dvar, load) <- doExpr (cmmToLlvmType ty)
+ (MetaExpr meta $ Load ptr)
return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
@@ -1099,7 +1103,6 @@ genLoad_slow env e ty = do
getCmmReg :: LlvmEnv -> CmmReg -> ExprData
getCmmReg env r@(CmmLocal (LocalReg un _))
= let exists = varLookup un env
-
(newv, stmts) = allocReg r
nenv = varInsert un (pLower $ getVarType newv) env
in case exists of
@@ -1204,7 +1207,7 @@ funEpilogue Nothing = do
return (vars, concatOL stmts)
where
loadExpr r = do
- let reg = lmGlobalRegVar r
+ let reg = lmGlobalRegVar r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
return (v, unitOL s)
@@ -1214,7 +1217,7 @@ funEpilogue (Just live) = do
return (vars, concatOL stmts)
where
loadExpr r | r `elem` alwaysLive || r `elem` live = do
- let reg = lmGlobalRegVar r
+ let reg = lmGlobalRegVar r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
return (v, unitOL s)
loadExpr r = do
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index e0cebe5f21..187d1ecf03 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -11,6 +11,7 @@ module LlvmCodeGen.Ppr (
import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Data
+import LlvmCodeGen.Regs
import CLabel
import OldCmm
@@ -25,6 +26,16 @@ import Unique
-- * Top level
--
+-- | Header code for LLVM modules
+pprLlvmHeader :: Doc
+pprLlvmHeader =
+ moduleLayout
+ $+$ text ""
+ $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions)
+ $+$ ppLlvmMetas stgTBAA
+ $+$ text ""
+
+
-- | LLVM module layout description for the host target
moduleLayout :: Doc
moduleLayout =
@@ -64,11 +75,6 @@ moduleLayout =
#endif
--- | Header code for LLVM modules
-pprLlvmHeader :: Doc
-pprLlvmHeader =
- moduleLayout $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions)
-
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> Doc
pprLlvmData (globals, types) =
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index ecce7a317b..55b2e0db80 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -3,7 +3,8 @@
--
module LlvmCodeGen.Regs (
- lmGlobalRegArg, lmGlobalRegVar, alwaysLive
+ lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
+ stgTBAA, top, base, stack, heap, rx, tbaa, getTBAA
) where
#include "HsVersions.h"
@@ -11,8 +12,8 @@ module LlvmCodeGen.Regs (
import Llvm
import CmmExpr
-import Outputable ( panic )
import FastString
+import Outputable ( panic )
-- | Get the LlvmVar function variable storing the real register
lmGlobalRegVar :: GlobalReg -> LlvmVar
@@ -49,6 +50,8 @@ lmGlobalReg suf reg
DoubleReg 2 -> doubleGlobal $ "D2" ++ suf
_other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
++ ") not supported!"
+ -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
+ -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg
where
wordGlobal name = LMNLocalVar (fsLit name) llvmWord
ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr
@@ -59,3 +62,41 @@ lmGlobalReg suf reg
alwaysLive :: [GlobalReg]
alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
+-- | STG Type Based Alias Analysis metadata
+stgTBAA :: [LlvmMeta]
+stgTBAA
+ = [ MetaUnamed topN [MetaStr (fsLit "top")]
+ , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN]
+ , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN]
+ , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN]
+ , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN]
+ ]
+
+-- | Id values
+topN, stackN, heapN, rxN, baseN :: LlvmMetaUnamed
+topN = LMMetaUnamed 0
+stackN = LMMetaUnamed 1
+heapN = LMMetaUnamed 2
+rxN = LMMetaUnamed 3
+baseN = LMMetaUnamed 4
+
+-- | The various TBAA types
+top, heap, stack, rx, base :: MetaData
+top = (tbaa, topN)
+heap = (tbaa, heapN)
+stack = (tbaa, stackN)
+rx = (tbaa, rxN)
+base = (tbaa, baseN)
+
+-- | The TBAA metadata identifier
+tbaa :: LMString
+tbaa = fsLit "tbaa"
+
+-- | Get the correct TBAA metadata information for this register type
+getTBAA :: GlobalReg -> MetaData
+getTBAA BaseReg = base
+getTBAA Sp = stack
+getTBAA Hp = heap
+getTBAA (VanillaReg _ _) = rx
+getTBAA _ = top
+
diff --git a/distrib/MacOS/GHC.xcodeproj/project.pbxproj b/distrib/MacOS/GHC.xcodeproj/project.pbxproj
index 738c68eded..471893cb2b 100644
--- a/distrib/MacOS/GHC.xcodeproj/project.pbxproj
+++ b/distrib/MacOS/GHC.xcodeproj/project.pbxproj
@@ -152,7 +152,7 @@
);
runOnlyForDeploymentPostprocessing = 0;
shellPath = /bin/sh;
- shellScript = "case \"$ACTION\" in clean) rm -rf \"$GHC_UNPACKS_INTO\" ;; build) tar -jxf \"$BINDIST\" && cd \"$GHC_UNPACKS_INTO\" && ./configure --prefix=\"$INSTALL_PATH/$CONTENTS_FOLDER_PATH/usr\" ;; install) cd \"$GHC_UNPACKS_INTO\" && make install DESTDIR=\"$DSTROOT\" ;; *) echo \"Unknown action $ACTION\" >&2 ; exit 1 ;; esac ";
+ shellScript = "case \"$ACTION\" in clean) rm -rf \"$GHC_UNPACKS_INTO\" ;; build) tar -jxf \"$BINDIST\" && cd \"$GHC_UNPACKS_INTO\" && ./configure --prefix=\"$INSTALL_PATH/$CONTENTS_FOLDER_PATH/usr\" --with-gcc=/usr/bin/gcc --with-gcc-4.2=/usr/bin/gcc ;; install) cd \"$GHC_UNPACKS_INTO\" && make install DESTDIR=\"$DSTROOT\" ;; *) echo \"Unknown action $ACTION\" >&2 ; exit 1 ;; esac ";
};
E76B00450D52DFDB00A05A2F /* ShellScript */ = {
isa = PBXShellScriptBuildPhase;
diff --git a/ghc.mk b/ghc.mk
index db3070e2da..1bd8976204 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -1151,7 +1151,10 @@ clean_libraries: $(patsubst %,clean_libraries/%_dist-boot,$(PACKAGES_STAGE0))
clean_libraries:
$(call removeTrees,$(patsubst %, libraries/%/dist, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
- $(call removeFiles,$(patsubst %, $(wildcard libraries/%/*.buildinfo), $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
+ $(call removeFiles,$(wildcard $(patsubst %, libraries/%/*.buildinfo, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))))
+ $(call removeFiles,$(patsubst %, libraries/%/config.log, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
+ $(call removeFiles,$(patsubst %, libraries/%/config.status, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
+ $(call removeFiles,$(wildcard $(patsubst %, libraries/%/include/Hs*Config.h, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))))
# We have to define a clean target for each library manually, because the
# libraries/*/ghc.mk files are not included when we're cleaning.
@@ -1186,10 +1189,6 @@ distclean : clean
$(call removeFiles,libraries/old-time/include/HsTimeConfig.h)
$(call removeTrees,utils/ghc-pwd/dist)
$(call removeTrees,inplace)
-
- $(call removeFiles,$(patsubst %, libraries/%/config.log, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
- $(call removeFiles,$(patsubst %, libraries/%/config.status, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
- $(call removeFiles,$(patsubst %, $(wildcard,libraries/%/include/Hs*Config.h), $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
$(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
maintainer-clean : distclean
diff --git a/rts/Linker.c b/rts/Linker.c
index 7fc6d0a804..9fb3f68fb9 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1524,16 +1524,17 @@ lookupSymbol( char *lbl )
/* On OS X 10.3 and later, we use dlsym instead of the old legacy
interface.
- HACK: On OS X, global symbols are prefixed with an underscore.
+ HACK: On OS X, all symbols are prefixed with an underscore.
However, dlsym wants us to omit the leading underscore from the
- symbol name. For now, we simply strip it off here (and ONLY
+ symbol name -- the dlsym routine puts it back on before searching
+ for the symbol. For now, we simply strip it off here (and ONLY
here).
*/
IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s with dlsym\n", lbl));
- ASSERT(lbl[0] == '_');
- return dlsym(dl_prog_handle, lbl+1);
+ ASSERT(lbl[0] == '_');
+ return dlsym(dl_prog_handle, lbl + 1);
# else
- if(NSIsSymbolNameDefined(lbl)) {
+ if (NSIsSymbolNameDefined(lbl)) {
NSSymbol symbol = NSLookupAndBindSymbol(lbl);
return NSAddressOfSymbol(symbol);
} else {
@@ -4765,7 +4766,7 @@ resolveImports(
#endif
- for(i=0; i*itemSize < sect->size;i++)
+ for(i = 0; i * itemSize < sect->size; i++)
{
// according to otool, reserved1 contains the first index into the indirect symbol table
struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
@@ -4782,9 +4783,11 @@ resolveImports(
addr = lookupSymbol(nm);
IF_DEBUG(linker, debugBelch("resolveImports: looking up %s, %p\n", nm, addr));
}
- if (!addr)
+
+ if (addr == NULL)
{
- errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
+ errorBelch("\nlookupSymbol failed in resolveImports\n"
+ "%s: unknown symbol `%s'", oc->fileName, nm);
return 0;
}
ASSERT(addr);
@@ -4809,7 +4812,8 @@ resolveImports(
return 1;
}
-static unsigned long relocateAddress(
+static unsigned long
+relocateAddress(
ObjectCode* oc,
int nSections,
struct section* sections,
@@ -4832,7 +4836,8 @@ static unsigned long relocateAddress(
return 0;
}
-static int relocateSection(
+static int
+relocateSection(
ObjectCode* oc,
char *image,
struct symtab_command *symLC, struct nlist *nlist,
@@ -4857,7 +4862,7 @@ static int relocateSection(
relocs = (struct relocation_info*) (image + sect->reloff);
- for(i=0;i<n;i++)
+ for(i = 0; i < n; i++)
{
#ifdef x86_64_HOST_ARCH
struct relocation_info *reloc = &relocs[i];
@@ -4870,6 +4875,15 @@ static int relocateSection(
uint64_t baseValue;
int type = reloc->r_type;
+ IF_DEBUG(linker, debugBelch("relocateSection: relocation %d\n", i));
+ IF_DEBUG(linker, debugBelch(" : type = %d\n", reloc->r_type));
+ IF_DEBUG(linker, debugBelch(" : address = %d\n", reloc->r_address));
+ IF_DEBUG(linker, debugBelch(" : symbolnum = %u\n", reloc->r_symbolnum));
+ IF_DEBUG(linker, debugBelch(" : pcrel = %d\n", reloc->r_pcrel));
+ IF_DEBUG(linker, debugBelch(" : length = %d\n", reloc->r_length));
+ IF_DEBUG(linker, debugBelch(" : extern = %d\n", reloc->r_extern));
+ IF_DEBUG(linker, debugBelch(" : type = %d\n", reloc->r_type));
+
checkProddableBlock(oc,thingPtr);
switch(reloc->r_length)
{
@@ -4898,34 +4912,86 @@ static int relocateSection(
reloc->r_length, thing, (char *)baseValue));
if (type == X86_64_RELOC_GOT
- || type == X86_64_RELOC_GOT_LOAD)
+ || type == X86_64_RELOC_GOT_LOAD)
{
struct nlist *symbol = &nlist[reloc->r_symbolnum];
char *nm = image + symLC->stroff + symbol->n_un.n_strx;
+ void *addr = NULL;
IF_DEBUG(linker, debugBelch("relocateSection: making jump island for %s, extern = %d, X86_64_RELOC_GOT\n", nm, reloc->r_extern));
+
ASSERT(reloc->r_extern);
- value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, (unsigned long)lookupSymbol(nm))->addr;
+ if (reloc->r_extern == 0) {
+ errorBelch("\nrelocateSection: global offset table relocation for symbol with r_extern == 0\n");
+ }
+
+ if (symbol->n_type & N_EXT) {
+ // The external bit is set, meaning the symbol is exported,
+ // and therefore can be looked up in this object module's
+ // symtab, or it is undefined, meaning dlsym must be used
+ // to resolve it.
+
+ addr = lookupSymbol(nm);
+ IF_DEBUG(linker, debugBelch("relocateSection: looked up %s, "
+ "external X86_64_RELOC_GOT or X86_64_RELOC_GOT_LOAD\n", nm));
+ IF_DEBUG(linker, debugBelch(" : addr = %p\n", addr));
+
+ if (addr == NULL) {
+ errorBelch("\nlookupSymbol failed in relocateSection (RELOC_GOT)\n"
+ "%s: unknown symbol `%s'", oc->fileName, nm);
+ return 0;
+ }
+ } else {
+ IF_DEBUG(linker, debugBelch("relocateSection: %s is not an exported symbol\n", nm));
+
+ // The symbol is not exported, or defined in another
+ // module, so it must be in the current object module,
+ // at the location given by the section index and
+ // symbol address (symbol->n_value)
+
+ if ((symbol->n_type & N_TYPE) == N_SECT) {
+ addr = (void *)relocateAddress(oc, nSections, sections, symbol->n_value);
+ IF_DEBUG(linker, debugBelch("relocateSection: calculated relocation %p of "
+ "non-external X86_64_RELOC_GOT or X86_64_RELOC_GOT_LOAD\n",
+ (void *)symbol->n_value));
+ IF_DEBUG(linker, debugBelch(" : addr = %p\n", addr));
+ } else {
+ errorBelch("\nrelocateSection: %s is not exported,"
+ " and should be defined in a section, but isn't!\n", nm);
+ }
+ }
+
+ value = (uint64_t) &makeSymbolExtra(oc, reloc->r_symbolnum, (unsigned long)addr)->addr;
type = X86_64_RELOC_SIGNED;
}
- else if(reloc->r_extern)
+ else if (reloc->r_extern)
{
struct nlist *symbol = &nlist[reloc->r_symbolnum];
char *nm = image + symLC->stroff + symbol->n_un.n_strx;
+ void *addr = NULL;
IF_DEBUG(linker, debugBelch("relocateSection: looking up external symbol %s\n", nm));
IF_DEBUG(linker, debugBelch(" : type = %d\n", symbol->n_type));
IF_DEBUG(linker, debugBelch(" : sect = %d\n", symbol->n_sect));
IF_DEBUG(linker, debugBelch(" : desc = %d\n", symbol->n_desc));
IF_DEBUG(linker, debugBelch(" : value = %p\n", (void *)symbol->n_value));
+
if ((symbol->n_type & N_TYPE) == N_SECT) {
value = relocateAddress(oc, nSections, sections,
symbol->n_value);
IF_DEBUG(linker, debugBelch("relocateSection, defined external symbol %s, relocated address %p\n", nm, (void *)value));
}
else {
- value = (uint64_t) lookupSymbol(nm);
+ addr = lookupSymbol(nm);
+ if (addr == NULL)
+ {
+ errorBelch("\nlookupSymbol failed in relocateSection (relocate external)\n"
+ "%s: unknown symbol `%s'", oc->fileName, nm);
+ return 0;
+ }
+
+ value = (uint64_t) addr;
IF_DEBUG(linker, debugBelch("relocateSection: external symbol %s, address %p\n", nm, (void *)value));
}
}
View Lorry Controller Status